Routine: BLRDPT0

BLRDPT0 ; IHS/DIR/FJE - PATIENT VARIABLE ROUTINE DRIVER, CONT. ; [ 06/16/98  11:25 AM ]

 ;;5.2;BLR;**1003**;JUN 01, 1998

 ;;MAS VERSION 5.0;

 ;Initialize variables

 N I1  ;IHS/DIR/AAB 06/12/98

 S U="^" D DT^DICRW:'$D(DT)

 S VAERR=$S('$D(DFN)#2:1,'$D(^DPT(DFN,0)):1,1:0)

 S Y=VAN'=13 I Y,$D(VAROOT)'[0,VAROOT]"" S Y=0,VAV=VAROOT K @VAV

 I Y S:$S(VAN>9:1,'$D(VAHOW):0,1:VAHOW[2) VAV="^UTILITY("_""""_VAV_""""_","_$J_")"

 D @VAN

Q K X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ,I1 Q

INIT ; -- determine #'s or names then init array

 S VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17"

 I VAN<10,$D(VAHOW),VAHOW[1 S VAS=$P($T(SS+VAN),";;",2)

 I $D(VAN(1)) F I=1:1:VAN(1) S @VAV@($P(VAS,"^",I))=""

1 ; -- [DEM] demos

 D C1,INIT I 'VAERR D 1^BLRDPT1,13 Q

2 ; -- [OPD] other pt vars

 D C2,INIT,2^BLRDPT1:'VAERR Q

3 ; -- [ADD] current address

 D C3,INIT,3^BLRDPT1:'VAERR Q

4 ; -- [OAD] other pt vars

 D C4,INIT,4^BLRDPT1:'VAERR Q

5 ; -- [INP] inpt data -v5

 D C5,INIT,5^BLRDPT2:'VAERR Q

6 ; -- [IN5] inpt data v5

 D C6,INIT F I=13:1:17 F I1=1:1:7 S @VAV@($P(VAS,"^",I),I1)=""

 D 6^BLRDPT3:'VAERR Q

7 ; -- [ELIG] elig data

 D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)=""

 D 7^BLRDPT4:'VAERR Q

8 ; -- [MB] $ benefits

 D C8,INIT D 8^BLRDPT4:'VAERR Q

9 ; -- [SVC] service data

 D C9,INIT F I=1:1:8 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)=""

 S @VAV@($P(VAS,"^",2),3)="",@VAV@($P(VAS,"^",2),4)="",@VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)=""

 F I=6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)=""

 D 9^BLRDPT4:'VAERR Q

10 ; -- [REG] registration data

 D C10,INIT D 10^BLRDPT5:'VAERR Q

11 ; -- [SDE] clinic enrollment data

 D C11,INIT D 11^BLRDPT5:'VAERR Q

12 ; -- [SDA] appt data

 D C12,INIT D 12^BLRDPT5:'VAERR Q

13 ; -- [PID] pt id's

 S (VA("PID"),VA("BID"))="" D 13^BLRDPT6:'VAERR Q

KVAR ; kill all vadpt data

 K VAN

C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN)

C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN)

C3 K X S:$D(VAPA("P")) X("P")=VAPA("P")

 K ^UTILITY("VAPA",$J),VAPA

 S:$D(X("P")) VAPA("P")=X("P") K X Q:$D(VAN)

C4 K X S:$D(VAOA("A")) X("A")=VAOA("A")

 K ^UTILITY("VAOA",$J),VAOA

 S:$D(X("A")) VAOA("A")=X("A") K X Q:$D(VAN)

C5 K ^UTILITY("VAIN",$J),VAIN Q:$D(VAN)

C6 K X F I="D","E","L","M","V" I $D(VAIP(I)) S X(I)=VAIP(I)

 S Y=$S('$D(VAIP("V")):"VAIP",VAIP("V")'?1A.E:"VAIP",1:VAIP("V")) K ^UTILITY(Y,$J),@Y

 F I="D","E","L","M","V" I $D(X(I)) S VAIP(I)=X(I)

 K X Q:$D(VAN)

C7 K ^UTILITY("VAEL",$J),VAEL Q:$D(VAN)

C8 K ^UTILITY("VAMB",$J),VAMB Q:$D(VAN)

C9 K ^UTILITY("VASV",$J),VASV Q:$D(VAN)

C10 K ^UTILITY("VARP",$J) Q:$D(VAN)

C11 K ^UTILITY("VAEN",$J) Q:$D(VAN)

C12 K ^UTILITY("VASD",$J) Q

C13 Q

SS ;  1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17

 ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS

 ;;BC^BS^FN^MN^MM^OC^ES

 ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE

 ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE

 ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT

 ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN

 ;;EL^PS^SC^VT^IN^TY^CN^ES^MT

 ;;AA^HB^SS^PE^MR^SI^DI^OR^GI

 ;;VN^AO^IR^PW^CS^S1^S2^S3

BLRDPT0   ; IHS/DIR/FJE - PATIENT VARIABLE ROUTINE DRIVER, CONT. ; [ 06/16/98  11:25 AM ]

 +1       ;;5.2;BLR;**1003**;JUN 01, 1998

 +2       ;

 +3       ;;MAS VERSION 5.0;

 +4       ;

 +5       ;Initialize variables

 +6       ;IHS/DIR/AAB 06/12/98

           NEW I1

 +7        SET U="^"

           IF '$DATA(DT)

               DO DT^DICRW

 +8        SET VAERR=$SELECT('$DATA(DFN)#2:1,'$DATA(^DPT(DFN,0)):1,1:0)

 +9        SET Y=VAN'=13

           IF Y

               IF $DATA(VAROOT)'[0

                   IF VAROOT]""

                       SET Y=0

                       SET VAV=VAROOT

                       KILL @VAV

 +10       IF Y

               IF $SELECT(VAN>9

                   SET VAV="^UTILITY("_""""_VAV_""""_","_$JOB_")"

 +11       DO @VAN

Q          KILL X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ,I1

           QUIT

 +1       ;

INIT      ; -- determine #'s or names then init array

 +1       ;

 +2        SET VAS="1^2^3^4^5^6^7^8^9^10^11^12^13^14^15^16^17"

 +3        IF VAN<10

               IF $DATA(VAHOW)

                   IF VAHOW[1

                       SET VAS=$PIECE($TEXT(SS+VAN),";;",2)

 +4        IF $DATA(VAN(1))

               FOR I=1:1:VAN(1)

                   SET @VAV@($PIECE(VAS,"^",I))=""

 +5        QUIT

 +6       ;

1         ; -- [DEM] demos

 +1        DO C1

           DO INIT

           IF 'VAERR

               DO 1^BLRDPT1

               DO 13

               QUIT

 +2       ;

2         ; -- [OPD] other pt vars

 +1        DO C2

           DO INIT

           IF 'VAERR

               DO 2^BLRDPT1

           QUIT

 +2       ;

3         ; -- [ADD] current address

 +1        DO C3

           DO INIT

           IF 'VAERR

               DO 3^BLRDPT1

           QUIT

 +2       ;

4         ; -- [OAD] other pt vars

 +1        DO C4

           DO INIT

           IF 'VAERR

               DO 4^BLRDPT1

           QUIT

 +2       ;

5         ; -- [INP] inpt data -v5

 +1        DO C5

           DO INIT

           IF 'VAERR

               DO 5^BLRDPT2

           QUIT

 +2       ;

6         ; -- [IN5] inpt data v5

 +1        DO C6

           DO INIT

           FOR I=13:1:17

               FOR I1=1:1:7

                   SET @VAV@($PIECE(VAS,"^",I),I1)=""

 +2        IF 'VAERR

               DO 6^BLRDPT3

           QUIT

 +3       ;

7         ; -- [ELIG] elig data

 +1        DO C7

           DO INIT

           FOR I=1:1:6

               SET @VAV@($PIECE(VAS,"^",5),I)=""

 +2        IF 'VAERR

               DO 7^BLRDPT4

           QUIT

 +3       ;

8         ; -- [MB] $ benefits

 +1        DO C8

           DO INIT

           IF 'VAERR

               DO 8^BLRDPT4

           QUIT

 +2       ;

9         ; -- [SVC] service data

 +1        DO C9

           DO INIT

           FOR I=1:1:8

               SET @VAV@($PIECE(VAS,"^",I),1)=""

               SET @VAV@($PIECE(VAS,"^",I),2)=""

 +2        SET @VAV@($PIECE(VAS,"^",2),3)=""

           SET @VAV@($PIECE(VAS,"^",2),4)=""

           SET @VAV@($PIECE(VAS,"^",4),3)=""

           SET @VAV@($PIECE(VAS,"^",5),3)=""

 +3        FOR I=6,7,8

               FOR I1=3,4,5

                   SET @VAV@($PIECE(VAS,"^",I),I1)=""

 +4        IF 'VAERR

               DO 9^BLRDPT4

           QUIT

 +5       ;

10        ; -- [REG] registration data

 +1        DO C10

           DO INIT

           IF 'VAERR

               DO 10^BLRDPT5

           QUIT

 +2       ;

11        ; -- [SDE] clinic enrollment data

 +1        DO C11

           DO INIT

           IF 'VAERR

               DO 11^BLRDPT5

           QUIT

 +2       ;

12        ; -- [SDA] appt data

 +1        DO C12

           DO INIT

           IF 'VAERR

               DO 12^BLRDPT5

           QUIT

 +2       ;

13        ; -- [PID] pt id's

 +1        SET (VA("PID"),VA("BID"))=""

           IF 'VAERR

               DO 13^BLRDPT6

           QUIT

 +2       ;

KVAR      ; kill all vadpt data

 +1        KILL VAN

C1         KILL ^UTILITY("VADM",$JOB),VADM

           IF $DATA(VAN)

               QUIT

C2         KILL ^UTILITY("VAPD",$JOB),VAPD

           IF $DATA(VAN)

               QUIT

C3         KILL X

           IF $DATA(VAPA("P"))

               SET X("P")=VAPA("P")

 +1        KILL ^UTILITY("VAPA",$JOB),VAPA

 +2        IF $DATA(X("P"))

               SET VAPA("P")=X("P")

           KILL X

           IF $DATA(VAN)

               QUIT

C4         KILL X

           IF $DATA(VAOA("A"))

               SET X("A")=VAOA("A")

 +1        KILL ^UTILITY("VAOA",$JOB),VAOA

 +2        IF $DATA(X("A"))

               SET VAOA("A")=X("A")

           KILL X

           IF $DATA(VAN)

               QUIT

C5         KILL ^UTILITY("VAIN",$JOB),VAIN

           IF $DATA(VAN)

               QUIT

C6         KILL X

           FOR I="D","E","L","M","V"

               IF $DATA(VAIP(I))

                   SET X(I)=VAIP(I)

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

           KILL ^UTILITY(Y,$JOB),@Y

 +2        FOR I="D","E","L","M","V"

               IF $DATA(X(I))

                   SET VAIP(I)=X(I)

 +3        KILL X

           IF $DATA(VAN)

               QUIT

C7         KILL ^UTILITY("VAEL",$JOB),VAEL

           IF $DATA(VAN)

               QUIT

C8         KILL ^UTILITY("VAMB",$JOB),VAMB

           IF $DATA(VAN)

               QUIT

C9         KILL ^UTILITY("VASV",$JOB),VASV

           IF $DATA(VAN)

               QUIT

C10        KILL ^UTILITY("VARP",$JOB)

           IF $DATA(VAN)

               QUIT

C11        KILL ^UTILITY("VAEN",$JOB)

           IF $DATA(VAN)

               QUIT

C12        KILL ^UTILITY("VASD",$JOB)

           QUIT

C13        QUIT

 +1       ;

SS        ;  1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17

 +1       ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS

 +2       ;;BC^BS^FN^MN^MM^OC^ES

 +3       ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE

 +4       ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE

 +5       ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT

 +6       ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN

 +7       ;;EL^PS^SC^VT^IN^TY^CN^ES^MT

 +8       ;;AA^HB^SS^PE^MR^SI^DI^OR^GI

 +9       ;;VN^AO^IR^PW^CS^S1^S2^S3

BLRDPT0.m