VADPT.m

VADPT ;ALB/MRL/MJK,ERC,TDM - RETURN PATIENT VARIABLE ARRAYS 

 ;;5.3;PIMS;**193,343,389,415,489,498,1004,1015,1016**;JUN 30, 2012;Build 20

 ;DFN = Patient IFN [if not passed entire array returned as null]

 ;IHS/ANMC/LJF  8/18/2000 added HRCN to kill of variables

 ;IHS/OIT/LJF  11/10/2005 PATCH 1004 included for sites where it has been overwritten

 ;

DEM ;Demographic Variables

 S VAN=1,VAN(1)=12,VAV="VADM" D ^VADPT0 Q

 ;

OPD ;Other Patient Data

 S VAN=2,VAN(1)=8,VAV="VAPD" D ^VADPT0 Q

 ;

ADD ;Current Address

 S VAN=3,VAN(1)=29,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)=14,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

 K HRCN  ;IHS/ANMC/LJF 8/18/2000 set when VA variables are set

 ;

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^

VADPT     ;ALB/MRL/MJK,ERC,TDM - RETURN PATIENT VARIABLE ARRAYS 

 +1       ;;5.3;PIMS;**193,343,389,415,489,498,1004,1015,1016**;JUN 30, 2012;Build 20

 +2       ;DFN = Patient IFN [if not passed entire array returned as null]

 +3       ;IHS/ANMC/LJF  8/18/2000 added HRCN to kill of variables

 +4       ;IHS/OIT/LJF  11/10/2005 PATCH 1004 included for sites where it has been overwritten

 +5       ;

DEM       ;Demographic Variables

 +1        SET VAN=1

           SET VAN(1)=12

           SET VAV="VADM"

           DO ^VADPT0

           QUIT 

 +2       ;

OPD       ;Other Patient Data

 +1        SET VAN=2

           SET VAN(1)=8

           SET VAV="VAPD"

           DO ^VADPT0

           QUIT 

 +2       ;

ADD       ;Current Address

 +1        SET VAN=3

           SET VAN(1)=29

           SET VAV="VAPA"

           DO ^VADPT0

           QUIT 

 +2       ;

OAD       ;Other Patient Variables

 +1        SET VAN=4

           SET VAN(1)=11

           SET VAV="VAOA"

           DO ^VADPT0

           QUIT 

 +2       ;

INP       ;Inpatient Data [pre-version 5]

 +1        NEW VAINDTT

           SET VAN=5

           SET VAN(1)=11

           SET VAV="VAIN"

           SET VAINDTT=$GET(VAINDT)

           NEW VAINDT

           IF VAINDTT

               SET VAINDT=$$DATIM(VAINDTT)

           DO ^VADPT0

           QUIT 

 +2       ;

IN5       ;Inpatient Data [v5.0 and above]

 +1        NEW VAINDTT

           SET VAN=6

           SET VAN(1)=19

           SET VAV=$SELECT('$DATA(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V"))

           SET VAINDTT=$GET(VAIP("D"))

           IF $LENGTH(VAINDTT)

               SET VAIP("D")=VAINDTT

           IF VAINDTT

               SET VAIP("D")=$$DATIM(VAINDTT)

           DO ^VADPT0

           IF $LENGTH(VAINDTT)

               SET VAIP("D")=VAINDTT

           QUIT 

 +2       ;

ELIG      ;Eligibility Information

 +1        SET VAN=7

           SET VAN(1)=9

           SET VAV="VAEL"

           DO ^VADPT0

           QUIT 

 +2       ;

MB        ;Monetary Benefits

 +1        SET VAN=8

           SET VAN(1)=9

           SET VAV="VAMB"

           DO ^VADPT0

           QUIT 

 +2       ;

SVC       ;Service Information

 +1        SET VAN=9

           SET VAN(1)=14

           SET VAV="VASV"

           DO ^VADPT0

           QUIT 

 +2       ;

REG       ;Registration data

 +1        SET VAN=10

           SET VAV="VARP"

           DO ^VADPT0

           QUIT 

 +2       ;

SDE       ;Enrollment Information

 +1        SET VAN=11

           SET VAV="VAEN"

           DO ^VADPT0

           QUIT 

 +2       ;

SDA       ;Appointment Information

 +1        SET VAN=12

           SET VAV="VASD"

           DO ^VADPT0

           QUIT 

 +2       ;

PID       ;Patient Id

 +1        SET VAN=13

           SET VAV="VA"

           DO ^VADPT0

           QUIT 

 +2       ;

TESTPAT(DFN) ;Test patient ?  Returns 0 (No) or 1 (Yes)

 +1        SET DFN=+$GET(DFN)

           IF 'DFN

               QUIT 0

 +2        IF $DATA(^DPT("ATEST",DFN))

               QUIT 1

 +3        NEW NODE

           SET NODE=$GET(^DPT(DFN,0))

 +4        IF $PIECE(NODE,"^",21)=1

               QUIT 1

 +5        IF $EXTRACT($PIECE(NODE,"^",9),1,5)="00000"

               QUIT 1

 +6        QUIT 0

 +7       ;

V5         SET X=$SELECT($DATA(^DG(43,1,"VERSION")):+^("VERSION"),1:"")

           SET VADPT("V")=$SELECT(X<5:0,1:1)

           KILL X

           QUIT 

OERR      ;

1          SET VATAG=1

           DO MULT

           QUIT 

2          SET VATAG=2

           DO MULT

           QUIT 

3          SET VATAG=3

           DO MULT

           QUIT 

4          SET VATAG=4

           DO MULT

           QUIT 

5          SET VATAG=5

           DO MULT

           QUIT 

6          SET VATAG=6

           DO MULT

           QUIT 

7          SET VATAG=7

           DO MULT

           QUIT 

8          SET VATAG=8

           DO MULT

           QUIT 

9          SET VATAG=9

           DO MULT

           QUIT 

10         SET VATAG=10

           DO MULT

           QUIT 

51         SET VATAG=11

           DO MULT

           QUIT 

52         SET VATAG=12

           DO MULT

           QUIT 

53         SET VATAG=13

           DO MULT

           QUIT 

ALL        SET VATAG=14

           DO MULT

           QUIT 

A5         SET VATAG=15

           DO MULT

           QUIT 

SEL        IF $ORDER(VARRAY(0))']""

               QUIT 

           SET VATAG=0

           SET VATAG(2)=$PIECE($TEXT(TAG),";;",2)

 +1        FOR VATAG(1)=0:0

               SET VATAG=$ORDER(VARRAY(VATAG))

               IF VATAG=""

                   QUIT 

               IF VATAG(2)[("^"_VATAG_"^")

                   SET VARRAY(VATAG)=1

                   SET VAROOT=$SELECT($DATA(VAROOT(VATAG)):VAROOT(VATAG),1:"")

                   DO @VATAG

 +2        GOTO Q

 +3       ;

MULT       SET VATAG=$PIECE($TEXT(TG+VATAG),";;",2)

 +1        FOR VATAG(1)=1:1

               SET VATAG(2)=$PIECE(VATAG,"^",VATAG(1))

               IF VATAG(2)=""

                   QUIT 

               SET VAROOT=$SELECT($DATA(VAROOT(VATAG(2))):VAROOT(VATAG(2)),1:"")

               DO @(VATAG(2))

Q          SET VAROOT=""

           IF $DATA(VAROOT)'=11

               KILL VAROOT

           KILL VATAG

           QUIT 

 +1       ;

KVA        KILL VA

 +1       ;IHS/ANMC/LJF 8/18/2000 set when VA variables are set

           KILL HRCN

 +2       ;

KVAR       DO KVAR^VADPT0

           IF $DATA(VAIP("V"))

               KILL @(VAIP("V"))

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

           QUIT 

DATIM(DATIM) ;If time not specified see if movement on that date

 +1        IF DATIM'?7N

               QUIT DATIM

 +2        NEW A,B

           SET A=$ORDER(^DGPM("ADFN"_DFN,DATIM))

           SET B=+$ORDER(^(+A,0))

 +3        IF 'A

               QUIT DATIM

 +4       ;Next movement is discharge

           IF $PIECE($GET(^DGPM(+B,0)),"^",2)=3

               QUIT DATIM

 +5        FOR 

               IF "^4^5^7^"'[(U_$PIECE($GET(^DGPM(+B,0)),"^",2))

                   QUIT 

               SET A=$ORDER(^DGPM("ADFN"_DFN,A))

               SET B=+$ORDER(^(+A,0))

               IF $EXTRACT(A,1,7)'=DATIM

                   QUIT 

 +6        IF 'A

               QUIT DATIM

 +7        IF $EXTRACT(A,1,7)'=DATIM

               QUIT DATIM

 +8        QUIT A

 +9       ;

TG        ;

 +1       ;;DEM^INP

 +2       ;;DEM^ELIG

 +3       ;;ELIG^INP

 +4       ;;DEM^ADD

 +5       ;;ADD^INP

 +6       ;;DEM^ELIG^ADD

 +7       ;;ELIG^SVC

 +8       ;;ELIG^SVC^MB

 +9       ;;DEM^REG^SDE^SDA

 +10      ;;SDE^SDA

 +11      ;;DEM^IN5

 +12      ;;ELIG^IN5

 +13      ;;ADD^IN5

 +14      ;;DEM^OPD^INP^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA

 +15      ;;DEM^OPD^IN5^ADD^ELIG^SVC^OAD^MB^REG^SDE^SDA

 +16      ;

TAG       ;;^DEM^OPD^INP^IN5^ADD^OAD^ELIG^SVC^MB^REG^SDE^SDA^