Single Patient Record Back-up

From VistApedia
Revision as of 05:56, 21 September 2009 by Harshal (talk | contribs)
Jump to: navigation, search

A method to obtain single patient record from VistA - Thanks to Alan for the solution.



Here is the Full documentation of the very basic starter program for selecting one patients file and printing there name and ssn. About five VistA routines are included for reference.

=======================================

USER>D ^%CD

Namespace: VISTA You're in namespace VISTA Default directory is c:\cachesys\mgr\vista\ VISTA>

VISTA>S DUZ=10000000020

VISTA>D ^XUP

Setting up programmer environment This is a TEST account.

Terminal Type set to: C-VT320

Select OPTION NAME: VISTA>

VISTA>D ^NAM3SSN

Select PATIENT NAME: ONE

 1   ONE,IMAGEPATIENT        4-15-53    666061001     NO     NSC

VETERAN

 2   ONE,INPATIENT        3-9-45    666000801     NO     NSC VETERAN
 3   ONE,OUTPATIENT        3-9-45    666000601     NO     NSC

VETERAN

 4   ONE,PATIENT        4-7-35    666000001     YES     SC VETERAN
 5   ONEHUNDRED,INPATIENT        3-9-45    666000900     NO     NSC

VETERAN

ENTER '^' TO STOP, OR CHOOSE 1-5: 4 ONE,PATIENT 4-7-35 666000001 YES SC VETERAN

Enrollment Priority: GROUP 3    Category: IN PROCESS    End Date:


Name: ONE,PATIENT SSN: 666000001

VISTA>


NAM3SSN ; Lab 9; TEST VISTA SELECT PATIENT NAME: W NAME & SSN; AHR; 09/14/2009

      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; FROM:
      ; DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY ;23 AUG 00 ;
      ; 5.3;Registration;**343**,Aug 13, 1993
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;

EN ;Entry point

      ;
      N DGDFN,DGPAT,DGNAM,DGSSN
      I DTIME="" S DTIME=30 ; added 1 line; TIMEOUT 4 READ set if ^XUP not

run

      S DGDFN=$$GETDFN()
      Q:DGDFN'>0
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;Searching for GETDFN() in *.*
      ;
      ; ALL THREE EXAMPLES OF GETDFN() ARE INCLUDED FOR REFERENCE
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;DGPHIST.int(9): S DGDFN=$$GETDFN()
      ;DGPHIST.int(22): GETDFN() ;Ask the user to select patient
      ;EASECPC.int(36): GETDFN() ; Get the veteran's DFN
      ;NAM3SSN.int(11): S DGDFN=$$GETDFN()
      ;NAM3SSN.int(30): ; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR

REFERENCE

      ;NAM3SSN.int(36): ;GETDFN() ;Ask the user to select patient
      ;NAM3SSN.int(54): GETDFN() ;Get pointer to PATIENT file (#2)
      ;NAM3SSN.mac(11): S DGDFN=$$GETDFN()
      ;NAM3SSN.mac(30): ; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR

REFERENCE

      ;NAM3SSN.mac(36): ;GETDFN() ;Ask the user to select patient
      ;NAM3SSN.mac(54): GETDFN() ;Get pointer to PATIENT file (#2)
      ;VAFCMS01.int(10): S DFN=$$GETDFN()
      ;VAFCMS01.int(18): GETDFN() ;Get pointer to PATIENT file (#2)
      ;VAFCMS01.int(225): S DFN=$$GETDFN()
      ;Found 14 occurrence/s in 5 file/s.
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; --->>> taking out the $$GETPAT(DGDFN) code because it is not

simple.

      ;
      ;S DGPAT=$$GETPAT(DGDFN)
      ;Q:$P(DGPAT,U)=""
      ;S DGNAM=$P(DGPAT,U),DGSSN=$P(DGPAT,U,2)
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      S DGNAM=$$NAME(DGDFN)
      ;
      S DGSSN=$$SSN(DGDFN)
      ;
      W !!,"Name: ",DGNAM," ","SSN: ",DGSSN,! ; Only line I have written
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; THIS CODE IS BEING USED
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; FROM:
      ; DGPHIST ;WASH/ERC - PURPLE HEART REQUEST HISTORY
      ;23 AUG 00 ;;5.3;Registration;**343**,Aug 13, 1993
      ;
      ; this code commented out for reference to the entry point above.

GETDFN() ;Ask the user to select patient

      ;
      ; Input: none
      ;
      ; Output: DFN
      ;
      N DIC,X,Y
      S DIC="^DPT(",DIC(0)="AEMQ"
      D ^DIC
      Q $S(+Y>0:+Y,1:0)
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; FROM:
      ; VAFCMS01 ;BP-CIOFO/JRP - ADMISSION RETRANSMISSION;8/3/1998 ;
      ; 5.3;Registration;**209**;Aug 13, 1993
      ;
      ; THIS NEXT GETDFN() NOT IN USE INCLUDED FOR REFERENCE
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; GETDFN() ;Get pointer to PATIENT file (#2)
      ; Input : None
      ;Output : DFN - Pointer to PATIENT file (#2)
      ; -1 - No entry selected
      ;
      ; N DIC,X,Y,DTOUT,DUOUT
      ; S DIC="^DPT("
      ; S DIC(0)="AEMNQZ"
      ; D ^DIC
      ; Q +Y
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ;EASECPC ;ALB/PHH,CKN,LBD,AMA,SCK - LTC Copayment Report; 29-AUG-2001
      ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,24,34,40,79**;Mar 15,

2001;Build 3

      ;
      ; This routine prints a report of calculated LTC copayments for a

veteran.

      ; It is called by menu option EASEC LTC COPAY PRINT
      ;
      ; EN N DFN,EASRPT,EASADM,EASRDT,MAXRT,DGMTI,DGMTDT
      ; Select which report to print (1=Institutional (IP); 2=Non-

Institutional (OP))

      ; S EASRPT=$$RPT Q:'EASRPT
      ; Select Patient
      ; S DFN=$$GETDFN Q:'DFN
      ; S EASADM=""
      ; Get the LTC admission date (if EASRPT=1)
      ; I EASRPT=1 S EASADM=$$ADMDT Q:'EASADM
      ; E S EASADM="" ;EAS*1.0*79
      ; Get start date for report
      ; S EASRDT=$$RPTDT Q:'EASRDT
      ;EAS*1.0*79 - moved from 4 lines up, and added EASADM as a parameter
      ;Set EASADM to the report date for Non-Institutional (OP) reports
      ; I EASRPT=2 S EASADM=EASRDT
      ; Get most recent LTC Copay Test for patient and set up LTC variables
      ; I '$$GETLTC(DFN,EASADM) Q
      ; Run the report
      ; D QUE
      ; Q
      ; RPT() ; Select which report to print
      ; Input: None
      ; Output: Y - Report Type (1=Institutional (IP); 2=Non-Institutional

(OP); 0=Quit)

      ; N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
      ; W !!,"Report of Calculated Long Term Care Copayments"
      ; W !,"=============================================="
      ; S DIR(0)="S^1:Institutional (Inpatient);2:Non-Institutional

(Outpatient)"

      ; S DIR("A")="Enter 1 or 2"
      ; D ^DIR I 'Y!($D(DTOUT))!($D(DUOUT)) Q 0
      ; Q Y
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ; GETDFN() ; Get the veteran's DFN
      ; N DIC,DTOUT,DUOUT,X,Y
      ; W !
      ; S DIC="^DPT(",DIC(0)="AEMZQ",DIC("S")="I $D(^DGMT(408.31,""AID"",

3,+Y))"

      ; D ^DIC
      ; Q:$D(DTOUT)!($D(DUOUT)) 0
      ; Q:Y<0 0
      ; Q +Y
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; MORE ROUTINE ....
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; FROM:
      ; DGENPTA ;ALB/CJM - Patient API - Retrieve Data; 13 JUN 1997
      ;;5.3;Registration;**121,122,147**;08/13/93
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;

SSN(DFN) ;

      ;Description: Function returns the patient's SSN, or "" on failure.
      ;
      Q:'DFN ""
      Q $P($G(^DPT(DFN,0)),"^",9)
      ;

NAME(DFN) ;

      ;Description: Function returns the patient's NAME, or "" on failure.
      ;
      Q:'DFN ""
      Q $P($G(^DPT(DFN,0)),"^")
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      QUIT ; END NAM2SSN
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      QUIT ; MAKE SURE ENDING HERE
      ;
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ;GETPAT(DFN) ;
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;Searching for GETPAT(DFN) in *.*
      ;
      ;DGPHIST.int(33): GETPAT(DFN) ; get patient name and ssn
      ;NAM3SSN.int(89): ;GETPAT(DFN) ;
      ;NAM3SSN.int(106): ; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED

FOR REFERENCE

      ;NAM3SSN.mac(89): ;GETPAT(DFN) ;
      ;NAM3SSN.mac(106): ; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED

FOR REFERENCE

      ;PSOTPCLP.int(130): D GETPAT(DFN)
      ;PSOTPCLP.int(148): GETPAT(DFN) ;GET PATIENT DATA
      ;Found 7 occurrence/s in 4 file/s.
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; Input: DFN - patient IEN
      ;
      ; Output:
      ; Function value: patient name^SSN
      ;
      ;N VADM,DGNAM,DGSSN
      ;S (DGNAM,DGSSN)=""
      ;I $G(DFN)>0 D
      ;. D ^VADPT ; CALLS THIS EXTERNAL PROCEDURE
      ;. S DGNAM=VADM(1)
      ;. S DGSSN=$P(VADM(2),U,2)
      ;Q DGNAM_"^"_DGSSN
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; EXTERNAL PROCEDURE USED BY GETPAT(DFN) INCLUDED FOR REFERENCE
      ;
      ;VADPT ;ALB/MRL/MJK - RETURN PATIENT VARIABLE ARRAYS [DRIVER];07 DEC

1988

      ;;5.3;Registration;**193,343,389,415,489,498**;Aug 13, 1993
      ;DFN = Patient IFN [if not passed entire array returned as null]
      ;
      ;DEM ;Demographic Variables
      ;S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q
      ;
      ;OPD ;Other Patient Data
      ;S VAN=2,VAN(1)=7,VAV="VAPD" D ^VADPT0 Q
      ;
      ;ADD ;Current Address
      ;S VAN=3,VAN(1)=22,VAV="VAPA" D ^VADPT0 Q
      ;
      ;OAD ;Other Patient Variables
      ;S VAN=4,VAN(1)=11,VAV="VAOA" D ^VADPT0 Q
      ;
      ;INP ;Inpatient Data [pre-version 5]
      ;N VAINDTT S VAN=5,VAN(1)=11,VAV="VAIN",VAINDTT=$G(VAINDT) N VAINDT

S:VAINDTT VAINDT=$$DATIM(VAINDTT) D ^VADPT0 Q

      ;
      ;IN5 ;Inpatient Data [v5.0 and above]
      ;N VAINDTT S VAN=6,VAN(1)=19,VAV=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?

1A.E:"VAIP",1:VAIP("V")),VAINDTT=$G(VAIP("D")) S:$L(VAINDTT) VAIP("D") =VAINDTT S:VAINDTT VAIP("D")=$$DATIM(VAINDTT) D ^VADPT0 S:$L(VAINDTT) VAIP("D")=VAINDTT Q

      ;
      ;ELIG ;Eligibility Information
      ;S VAN=7,VAN(1)=9,VAV="VAEL" D ^VADPT0 Q
      ;
      ;MB ;Monetary Benefits
      ;S VAN=8,VAN(1)=9,VAV="VAMB" D ^VADPT0 Q
      ;
      ;SVC ;Service Information
      ;S VAN=9,VAN(1)=9,VAV="VASV" D ^VADPT0 Q
      ;
      ;REG ;Registration data
      ;S VAN=10,VAV="VARP" D ^VADPT0 Q
      ;
      ;SDE ;Enrollment Information
      ;S VAN=11,VAV="VAEN" D ^VADPT0 Q
      ;
      ;SDA ;Appointment Information
      ;S VAN=12,VAV="VASD" D ^VADPT0 Q
      ;
      ;PID ;Patient Id
      ;S VAN=13,VAV="VA" D ^VADPT0 Q
      ;
      ;TESTPAT(DFN) ;Test patient ? Returns 0 (No) or 1 (Yes)
      ;S DFN=+$G(DFN) I 'DFN Q 0
      ;I $D(^DPT("ATEST",DFN)) Q 1
      ;N NODE S NODE=$G(^DPT(DFN,0))
      ;I $P(NODE,"^",21)=1 Q 1
      ;I $E($P(NODE,"^",9),1,5)="00000" Q 1
      ;Q 0
      ;
      ;V5 S X=$S($D(^DG(43,1,"VERSION")):+^("VERSION"),1:""),VADPT("V")=$S

(X<5:0,1:1) K X Q

      ;OERR ;
      ;1 S VATAG=1 D MULT Q
      ;2 S VATAG=2 D MULT Q
      ;3 S VATAG=3 D MULT Q
      ;4 S VATAG=4 D MULT Q
      ;5 S VATAG=5 D MULT Q
      ;6 S VATAG=6 D MULT Q
      ;7 S VATAG=7 D MULT Q
      ;8 S VATAG=8 D MULT Q
      ;9 S VATAG=9 D MULT Q
      ;10 S VATAG=10 D MULT Q
      ;51 S VATAG=11 D MULT Q
      ;52 S VATAG=12 D MULT Q
      ;53 S VATAG=13 D MULT Q
      ;ALL S VATAG=14 D MULT Q
      ;A5 S VATAG=15 D MULT Q
      ;SEL Q:$O(VARRAY(0))']"" S VATAG=0,VATAG(2)=$P($T(TAG),";;",2)
      ;F VATAG(1)=0:0 S VATAG=$O(VARRAY(VATAG)) Q:VATAG="" I VATAG(2)

[("^"_VATAG_"^") S VARRAY(VATAG)=1,VAROOT=$S($D(VAROOT(VATAG)):VAROOT (VATAG),1:"") D @VATAG

      ;G Q
      ;
      ;MULT S VATAG=$P($T(TG+VATAG),";;",2)
      ;F VATAG(1)=1:1 S VATAG(2)=$P(VATAG,"^",VATAG(1)) Q:VATAG(2)="" S

VAROOT=$S($D(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"") D @(VATAG(2))

      ;Q S VAROOT="" K:$D(VAROOT)'=11 VAROOT K VATAG Q
      ;
      ;KVA K VA
      ;KVAR D KVAR^VADPT0 K:$D(VAIP("V")) @(VAIP("V")) K

I,X,Y,VARRAY,VADM,VAPD,VADPT,VAOA,VASV,VAEL,VAMB,VARP,VAEN,VASD,VAIN,VAIP,VAPA,VAHOW,VAINDT,VAERR,^UTILITY ("VADPT",$J),VA200,VATEST Q

      ;DATIM(DATIM) ;If time not specified see if movement on that date
      ;Q:DATIM'?7N DATIM
      ;N A,B S A=$O(^DGPM("ADFN"_DFN,DATIM)),B=+$O(^(+A,0))
      ;I 'A Q DATIM
      ;I $P($G(^DGPM(+B,0)),"^",2)=3 Q DATIM ;Next movement is discharge
      ;F Q:"^4^5^7^"'[(U_$P($G(^DGPM(+B,0)),"^",2)) S A=$O(^DGPM

("ADFN"_DFN,A)),B=+$O(^(+A,0)) I $E(A,1,7)'=DATIM Q

      ;I 'A Q DATIM
      ;I $E(A,1,7)'=DATIM Q DATIM
      ;Q A
      ;
      ;TG ;
      ;;DEM^INP
      ;;DEM^ELIG
      ;;ELIG^INP
      ;;DEM^ADD
      ;;ADD^INP
      ;;DEM^ELIG^ADD
      ;;ELIG^SVC
      ;;ELIG^SVC^MB
      ;;DEM^REG^SDE^SDA
      ;;SDE^SDA
      ;;DEM^IN5
      ;;ELIG^IN5
      ;;ADD^IN5
      ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
      ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA
      ;
      ;TAG ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;
      ; VERY IMPORTANT EXAMPLE OF PATIENT LOOKUP MAIN ROUTINE
      ;
      ; DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05

4:19pm

      ;;

5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647**;Aug 13, 1993

      ;
       ; mods made for magstripe read 12/96 - JFP
      ;
      ;Optional input: DPTNOFZY='1' to suppress fuzzy lookups implemented
      ; by patch DG*5.3*244
      ;
      ;
      ;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
      ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm

5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647**;Aug 13, 1993

mods made for magstripe read 12/96 - JFP
Optional input
DPTNOFZY='1' to suppress fuzzy lookups implemented
by patch DG*5.3*244

EN ; -- Entry point N DIE,DR K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D (X))) I '$D(^DD("VERSION")) W !!?3,"Unable to proceed. Fileman version node ^DD(""VERSION"") is undefined." G QK I '$D(^DPT(0))!(^DD("VERSION")<17.2) W !!?3,"Unable to proceed. ",$S ('$D(^DPT(0)):"0th node of ^DPT missing",^DD("VERSION")<17.2:"Fileman version must be at least 17.2",1:""),"." G QK EN2 K DO,DUOUT,DTOUT S U="^",DIC="^DPT(",DIC(0)=$S($D(DIC(0)):DIC(0), 1:"AELMQ") S:DIC(0)'["A" (DPTX,DPTSAVX)=X S DPTSZ=1000 I $D(^DD("OS"))#2 S DPTSZ=$S(+$P(^DD("OS",^("OS"),0),U,2): $P(^(0),U,2),1:DPTSZ)

ASKPAT ; -- Prompt for patient I DIC(0)["A" D G QK:'$T!($E(DPTX)["^")!(DPTX="") .K DTOUT,DUOUT .W !,$S($D(DIC("A")):DIC("A"),1:"Select PATIENT NAME: ") W:$D(DIC ("B")) DIC("B"),"// " .R X:DTIME .S DPTX=X S:'$T DTOUT=1 S:$T&(DPTX="")&($D(DIC("B"))) DPTX=DIC("B") S:DPTX["^"&($E(DPTX)'="%") DUOUT=1

-- Check for the IATA magnetic stripe input

N MAG,GCHK S MAG=0 I $E(DPTX)="%"!($E(DPTX)=";"),DPTX["?" S MAG=1,(X,DPTX)=$$IATA(DPTX)

CHKPAT ; -- Custom Patient Lookup D DO^DIC1 S DIC("W")=$S($D(DIC("W")):DIC("W"),1:"") K DPTIFNS,DPTS,DPTSEL S DPTCNT=0

-- Check input for format an length

G CHKDFN:DPTX?1A!(DPTX'?.ANP)!($L(DPTX)>30)

-- Check for null response or abort

I DPTX=""!(DPTX["^") G ASKPAT:DIC(0)["A",QK

-- Check for question mark

I DPTX["?" D G ASKPAT:DIC(0)["A",QK .S D="B" .S DZ=$S(DPTX?1"?":"",1:"??") .G CHKPAT1:DZ="??" .N % .W !,?1,"Answer with PATIENT NAME, or SOCIAL SECURITY NUMBER, or last 4 digits",!,?4,"of SOCIAL SECURITY NUMBER, or first initial of" .W " last name with last",!,?4,"4 digits of SOCIAL SECURITY NUMBER" .W !,?1,"Do you want the entire ",+$P($G(^DPT(0)),"^",4),"-Entry PATIENT List" S %=0 D YN^DICN .Q:%'=1 .S DZ="??" CHKPAT1 .S X=DPTX .D DQ^DICQ

-- Check for space bar, return

I DPTX=" " D G CHKDFN .S Y=$S('($D(DUZ)#2):-1,$D(^DISV(DUZ,"^DPT(")):^("^DPT("),1:-1) .D SETDPT^DPTLK1:Y>0 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)

-- Check for DFN look up

I $E(DPTX)="`" D G CHKDFN .S Y=$S($D(^DPT(+$P(DPTX,"`",2),0)):+$P(DPTX,"`",2),1:-1) .D SETDPT^DPTLK1:Y>0 .S DPTDFN=$S($D(DPTS(Y)):Y,1:-1)

-- Puts input in correct format

G CHKDFN:DPTX=""

-- Force new entry

I $E(DPTX)="""",$E(DPTX,$L(DPTX))="""" G NOPAT

-- Check for index lookups

D ^DPTLK1 G QK:$D(DTOUT)!($D(DUOUT)&(DIC(0)'["A")),ASKPAT:$D (DUOUT),CHKPAT:DPTDFN<0,CHKDFN:DPTDFN>0 I DIC(0)["N",$D(^DPT(DPTX,0)) S Y=X D SETDPT^DPTLK1 S DPTDFN=$S($D(DPTS(Y)):Y,1:-1) G CHKDFN MAG ; -- No patient found, check for mag stripe input, create stub I 'MAG G NOPAT

-- Check for ADT option(s) only

N DGOPT S DGOPT=$P($G(XQY0),"^",2) I DGOPT'="Load/Edit Patient Data",DGOPT'="Register a Patient" D G EN2 .W !," ...Patient not in database, use ADT options to load patient" D Q1

-- Prompt for creation of stub

S DIR(0)="Y",DIR("B")="NO",DIR("A")="Patient not found...Create stub entry: " S GCHK=$D(^TMP("DGVIC")) D ^DIR K DIR I 'Y D Q1 G EN2

-- Parse IATA fields

D FIELDS(IATA)

-- Check for Duplicates

D EP2^DPTLK3 I DPTDFN<0 D Q1 G EN2

-- Creates Stub entry in patient file

S Y=$$FILE^DPTLK4(DGFLDS) I $P(Y,"^",3)'=1 W !,"Could not add patient to patient file" D QK1 Q D QK1 Q

NOPAT ; -- No patient found, ask to add new I DIC(0)["L" D ^DPTLK2 S Y=DPTDFN G ASKPAT:DIC(0)["A"&(Y<0)&('$G (DTOUT)),QK1

CHKDFN ; -- S:'$D(DPTDFN) DPTDFN=-1 I DPTDFN'>0!('$D(DPTS(+DPTDFN))) W:DIC(0)["Q"

  • 7," ??" G ASKPAT:DIC(0)["A",QK

I DIC(0)["E" D W $S('$D(DPTSEL)&('$D(DIVP)):$P(DPTS(DPTDFN),U,2)_" "_$P (DPTS(DPTDFN),U)_" ",$D(^DPT(DPTDFN,0)):" "_$P(^(0),U)_" ",1:"") S Y=DPTDFN X:$D(^DPT(DPTDFN,0)) "N DDS X DIC(""W"")" .I $D(DDS) D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X DDXY

check for other patients in "BS5" xref on Patient file

I '$G(DICR),DPTDFN>0,DIC(0)["E",$$BS5^DPTLK5(+DPTDFN) D G ASKPAT:DIC(0) ["A"&(%'=1),QK:DPTDFN<0 .N DPTZERO,DPTLSNME,DPTSSN S DPTZERO=$G(^DPT(+DPTDFN,0)),DPTLSNME=$P($P (DPTZERO,U),","),DPTSSN=$E($P(DPTZERO,U,9),6,9) .W $C(7),!!,"There is more than one patient whose last name is '",DPTLSNME,"' and" .W !,"whose social security number ends with '",DPTSSN,"'." .W !,"Are you sure you wish to continue (Y/N)" S %=0 D YN^DICN .I %'=1 S DPTDFN=-1

I '$G(DICR),DPTDFN>0 S Y=DPTDFN D ^DGSEC S DPTDFN=Y G ASKPAT:DIC(0) ["A"&(DPTDFN<0),QK:DPTDFN<0 S DPTX=DPTX_$P(DPTS(DPTDFN),U,2),DPTDFN=DPTDFN_U_$P(^DPT(DPTDFN,0),U)

Q ; -- S Y=$S('$D(DPTDFN):-1,'$D(DPTS(+DPTDFN)):-1,1:DPTDFN),X=$S($D(DPTX)& (+Y>0):DPTX,$D(DPTSAVX):DPTSAVX,$D(DPTX):DPTX,1:"") I Y>0 S:DIC(0)'["F" ^DISV($S($D(DUZ)#2:DUZ,1:0),"^DPT(")=+Y S:DIC(0) ["Z" Y(0)=^DPT(+Y,0),Y(0,0)=$P(^(0),U,1)

DG*600
I DIC(0)["E",$P($G(^DPT(+Y,0)),U,21) W *7,!,"Warning 
You have

selected a test patient." I DIC(0)["E",$$TESTPAT^VADPT(+Y) W *7,!,"WARNING : You may have selected a test patient." I DIC(0)["E",$$BADADR^DGUTL3(+Y) W *7,!,"WARNING : ** This patient has been flagged with a Bad Address Indicator." I DIC(0)["E",$$VAADV^DPTLK3(+Y) W *7,!,"** Patient is VA ADVANTAGE."

DG*485

I $D(^DPT("AXFFP",1,+Y)) D FFP^DPTLK5

Display enrollment information

I Y>0,DIC(0)["E" D ENR

Call Combat Vet check

I Y>0,DIC(0)["E" D CV

check whether to display Means Test Required message

D .N DPTDIV .I '$G(DUZ(2)) Q .I Y>0,DIC(0)["E" S DPTDIV=$$DMT^DPTLK5(+Y,DUZ(2)) I DPTDIV D ..W $C(7),!!,"MEANS TEST REQUIRED" ..W !,?3,$P($G(^DG(40.8,DPTDIV,"MT")),U,2) ..H 2

Q1 ; -- Clean up variables K D,DIC("W"),DO,DPTCNT,DPTDFN,DPTIFNS,DPTIX,DPTS K DPTSAVX,DPTSEL,DPTSZ,DPTX

K:$D(IATA) IATA K:$D(DGFLDS) @DGFLDS,DGFLDS Q

QK K:'$D(DPTNOFZK) DPTNOFZY G Q

QK1 K:'$D(DPTNOFZK) DPTNOFZY G Q1

IX ; -- I $D(D),$D(^DD(2,0,"IX",D)),($E(D)'="A") S DPTIX=D G DPTLK

IATA(X) ; --

This function pulls off ssn from the IATA track
Input
X - what was read in
Output
SSN - social security number
Q - quit
Track Start Sent End Sent Field Separator
----- ---------- -------- ---------------
IATA (alphanum) % ? { (Note
VA used ^)
ABA (numeric) ; ? =
N IATA

S (IATA)="" I $E(X)'="%" Q X ; no start sentinel I X'["?" Q "Q"

-- Extract data from track

S IATA=$$TRACK(X,"%","?")

-- checks for no data

I IATA="" Q "Q"

-- Returns SSN

I IATA'="" Q $P(IATA,"^") Q "Q"

TRACK(X,START,END) ; find track where start/end are sentinels

Q $P($P($G(X),START,2),END,1)

FIELDS(IATA) ; -- Sets fields Q:'$D(IATA) N CNT,FIELD S DGFLDS="^TMP(""DGVIC"","_$J_")",CNT=1 K @DGFLDS F S FIELD=$P($G(IATA),"^",CNT) Q:FIELD="" D .S @DGFLDS@(CNT)=FIELD .S CNT=CNT+1

-- Define fields for duplicate checker

S DPTX=$G(@DGFLDS@(2)) ;NAME S DPTIDS(.03)=$G(@DGFLDS@(3)) ;DOB S DPTIDS(.09)=$G(@DGFLDS@(1)) ;SSN Q ENR ;Display Enrollment information after patient selection N DGENCAT,DGENDFN,DGENR,DGEGTIEN,DGEGT I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) Q S DGENCAT=$$CATEGORY^DGENA4(+DPTDFN) S DGENCAT=$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT) W !?1,"Enrollment Priority: ",$S($G(DGENR("PRIORITY")):$$EXT^DGENU ("PRIORITY",DGENR("PRIORITY")),1:""),$S($G(DGENR("SUBGRP"))="":"",1:$ $EXT^DGENU("SUBGRP",$G(DGENR("SUBGRP")))) W ?33,"Category: ",DGENCAT W ?57,"End Date: ",$S($G(DGENR("END")):$$FMTE^XLFDT(DGENR ("END"),"5DZ"),1:""),!

If patient is NOT ELIGIBLE, display Enrollment Status (Ineligible

Project Phase I) I $G(DGENR("STATUS"))=10!($G(DGENR("STATUS"))=19)!($G(DGENR("STATUS")) =20) D . W ?1,"Enrollment Status: ",$S($G(DGENR("STATUS")):$$EXT^DGENU ("STATUS",DGENR("STATUS")),1:"") ;H 5

check for Combat Veteran Eligibility, if elig do not display EGT info

I $$CVEDT^DGCV(+DPTDFN) Q

Get Enrollment Group Threshold Priority and Subgroup

S DGEGTIEN=$$FINDCUR^DGENEGT S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT) Q:$G(DGENR("PRIORITY"))=""!($G(DGEGT("PRIORITY"))="")

Compare Patient's Enrollment Priority to Enrollment Group Threshold

I '$$ABOVE^DGENEGT1(+DPTDFN,DGENR("PRIORITY"),$G(DGENR("SUBGRP")),DGEGT ("PRIORITY"),DGEGT("SUBGRP")) D .N X,IORVOFF,IORVON .S X="IORVOFF;IORVON" .D ENDR^%ZISS .W !?32 W:$D(IORVON) IORVON W "*** WARNING ***" W:$D(IORVOFF) IORVOFF .I DGENR("END")'="" W !?14 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT END",$S(DT>+DGENR("END"):"ED",1:"S")," EFFECTIVE ",$ $FMTE^XLFDT(DGENR("END"),"5DZ")," ***" W:$D(IORVOFF) IORVOFF Q .W !?5 W:$D(IORVON) IORVON W "*** PATIENT ENROLLMENT ENDING. ENROLLMENT END DATE IS NOT KNOWN. ***" W:$D(IORVOFF) IORVOFF Q CV ;check for Combat Vet status N DGCV S DGCV=$$CVEDT^DGCV(+DPTDFN) I $P(DGCV,U)=1 D Q . I '$$GET^DGENA($$FINDCUR^DGENA(+DPTDFN),.DGENR) W ! . W ?3,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE", 1:"EXPIRED"),?57,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")