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))=""
Q
;
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
