- VADPT0 ;ALB/MRL,MJK,ERC,TDM,ARF,JAM,JMM - PATIENT VARIABLE ROUTINE DRIVER, CONT. ;02/22/2016
- ;;5.3;Registration;**343,342,415,489,498,528,689,789,688,759,754,887,952,996,1059,1064,1103,1121**;Aug 13, 1993;Build 14
- ;
- ;Initialize variables
- N I1
- S U="^" D DT^DICRW:'$D(DT)
- S VAERR=$S($G(DFN)="":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 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^18^19^20^21^22^23^24^25^26^27^28^29"
- 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^VADPT1,13 Q
- ;
- 01 ; -- [DEMUPD] demos with PREFERRED NAME added - DG*5.3*996
- D C01,INIT S @VAV@($P(VAS,"^",1),1)="" I 'VAERR D 1^VADPT1 S @VAV@($P(VAS,"^",1),1)=$$GET1^DIQ(2,+DFN_",",.2405,"E") D 13 Q
- ;
- 2 ; -- [OPD] other pt vars
- D C2,INIT,2^VADPT1:'VAERR Q
- ;
- 3 ; -- [ADD] current address
- D C3,INIT,3^VADPT1:'VAERR Q
- ;
- 4 ; -- [OAD] other pt vars
- D C4,INIT,4^VADPT1:'VAERR Q
- ;
- 5 ; -- [INP] inpt data -v5
- D C5,INIT,5^VADPT2:'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)=""
- F I=1:1:3 S @VAV@($P(VAS,"^",19),I)=""
- D 6^VADPT3:'VAERR Q
- ;
- 7 ; -- [ELIG] elig data
- D C7,INIT F I=1:1:6 S @VAV@($P(VAS,"^",5),I)=""
- D 7^VADPT4:'VAERR Q
- ;
- 8 ; -- [MB] $ benefits
- D C8,INIT D 8^VADPT4:'VAERR Q
- ;
- 9 ; -- [SVC] service data
- D C9,INIT F I=1:1:9 S @VAV@($P(VAS,"^",I),1)="",@VAV@($P(VAS,"^",I),2)=""
- S @VAV@($P(VAS,"^",10),1)=""
- F I=11:1:13 S @VAV@($P(VAS,"^",I))=0
- S @VAV@($P(VAS,"^",14),1)=""
- S @VAV@($P(VAS,"^",4),3)="",@VAV@($P(VAS,"^",5),3)=""
- F I=2,6,7,8 F I1=3,4,5 S @VAV@($P(VAS,"^",I),I1)=""
- D 9^VADPT4:'VAERR Q
- ;
- 10 ; -- [REG] registration data
- D C10,INIT D 10^VADPT5:'VAERR Q
- ;
- 11 ; -- [SDE] clinic enrollment data
- D C11,INIT D 11^VADPT5:'VAERR Q
- ;
- 12 ; -- [SDA] appt data
- D C12,INIT D 12^VADPT5:'VAERR Q
- ;
- 13 ; -- [PID] pt id's
- S (VA("PID"),VA("BID"))="" D 13^VADPT6:'VAERR Q
- ;
- KVAR ; kill all vadpt data
- K VAN
- C1 K ^UTILITY("VADM",$J),VADM Q:$D(VAN)
- C01 K ^UTILITY("VADEMO",$J),VADEMO Q:$D(VAN) ;DG*5.3*996
- C2 K ^UTILITY("VAPD",$J),VAPD Q:$D(VAN)
- C3 K X S:$D(VAPA("P")) X("P")=VAPA("P")
- S:$D(VAPA("CD")) X("CD")=VAPA("CD")
- K ^UTILITY("VAPA",$J),VAPA
- S:$D(X("P")) VAPA("P")=X("P") K X("P")
- S:$D(X("CD")) VAPA("CD")=X("CD") 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
- ;
- ; DG*5.3*1064 - add subscript IND to 16th piece
- ; DG*5.3*1103 - TERA indicator to 15th piece of line SS+9
- ; DG*5.3.1121 - add Persian Gulf Indicator to 16th piece of SS+9
- ; DG*5.3*1121 - add Last Change Date of Persian Gulf Indicator to SS+9
- SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28
- ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC^PL^SOGI^IND
- ;;BC^BS^FN^MN^MM^OC^ES^WP
- ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY^PR^PC^CT^CPR^CPC^CCT^CPN
- ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4
- ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP
- ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP^FD
- ;;EL^PS^SC^VT^IN^TY^CN^ES^MT^OTH
- ;;AA^HB^SS^PE^MR^SI^DI^OR^GI
- ;;VN^AO^IR^PW^CS^S1^S2^S3^PH^CV^OIF^OEF^UNK^SHD^TERA^PGI^LCD
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT0 4024 printed Mar 13, 2025@22:05:54 Page 2
- VADPT0 ;ALB/MRL,MJK,ERC,TDM,ARF,JAM,JMM - PATIENT VARIABLE ROUTINE DRIVER, CONT. ;02/22/2016
- +1 ;;5.3;Registration;**343,342,415,489,498,528,689,789,688,759,754,887,952,996,1059,1064,1103,1121**;Aug 13, 1993;Build 14
- +2 ;
- +3 ;Initialize variables
- +4 NEW I1
- +5 SET U="^"
- if '$DATA(DT)
- DO DT^DICRW
- +6 SET VAERR=$SELECT($GET(DFN)="":1,'$DATA(^DPT(DFN,0)):1,1:0)
- +7 SET Y=VAN'=13
- IF Y
- IF $DATA(VAROOT)'[0
- IF VAROOT]""
- SET Y=0
- SET VAV=VAROOT
- KILL @VAV
- +8 IF Y
- if $SELECT(VAN>9
- SET VAV="^UTILITY("_""""_VAV_""""_","_$JOB_")"
- +9 DO @VAN
- Q KILL X,Y,VAC,VAS,VAV,VAW,VAN,I,VAX,VAZ
- 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^18^19^20^21^22^23^24^25^26^27^28^29"
- +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^VADPT1
- DO 13
- QUIT
- +2 ;
- 01 ; -- [DEMUPD] demos with PREFERRED NAME added - DG*5.3*996
- +1 DO C01
- DO INIT
- SET @VAV@($PIECE(VAS,"^",1),1)=""
- IF 'VAERR
- DO 1^VADPT1
- SET @VAV@($PIECE(VAS,"^",1),1)=$$GET1^DIQ(2,+DFN_",",.2405,"E")
- DO 13
- QUIT
- +2 ;
- 2 ; -- [OPD] other pt vars
- +1 DO C2
- DO INIT
- if 'VAERR
- DO 2^VADPT1
- QUIT
- +2 ;
- 3 ; -- [ADD] current address
- +1 DO C3
- DO INIT
- if 'VAERR
- DO 3^VADPT1
- QUIT
- +2 ;
- 4 ; -- [OAD] other pt vars
- +1 DO C4
- DO INIT
- if 'VAERR
- DO 4^VADPT1
- QUIT
- +2 ;
- 5 ; -- [INP] inpt data -v5
- +1 DO C5
- DO INIT
- if 'VAERR
- DO 5^VADPT2
- 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 FOR I=1:1:3
- SET @VAV@($PIECE(VAS,"^",19),I)=""
- +3 if 'VAERR
- DO 6^VADPT3
- QUIT
- +4 ;
- 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^VADPT4
- QUIT
- +3 ;
- 8 ; -- [MB] $ benefits
- +1 DO C8
- DO INIT
- if 'VAERR
- DO 8^VADPT4
- QUIT
- +2 ;
- 9 ; -- [SVC] service data
- +1 DO C9
- DO INIT
- FOR I=1:1:9
- SET @VAV@($PIECE(VAS,"^",I),1)=""
- SET @VAV@($PIECE(VAS,"^",I),2)=""
- +2 SET @VAV@($PIECE(VAS,"^",10),1)=""
- +3 FOR I=11:1:13
- SET @VAV@($PIECE(VAS,"^",I))=0
- +4 SET @VAV@($PIECE(VAS,"^",14),1)=""
- +5 SET @VAV@($PIECE(VAS,"^",4),3)=""
- SET @VAV@($PIECE(VAS,"^",5),3)=""
- +6 FOR I=2,6,7,8
- FOR I1=3,4,5
- SET @VAV@($PIECE(VAS,"^",I),I1)=""
- +7 if 'VAERR
- DO 9^VADPT4
- QUIT
- +8 ;
- 10 ; -- [REG] registration data
- +1 DO C10
- DO INIT
- if 'VAERR
- DO 10^VADPT5
- QUIT
- +2 ;
- 11 ; -- [SDE] clinic enrollment data
- +1 DO C11
- DO INIT
- if 'VAERR
- DO 11^VADPT5
- QUIT
- +2 ;
- 12 ; -- [SDA] appt data
- +1 DO C12
- DO INIT
- if 'VAERR
- DO 12^VADPT5
- QUIT
- +2 ;
- 13 ; -- [PID] pt id's
- +1 SET (VA("PID"),VA("BID"))=""
- if 'VAERR
- DO 13^VADPT6
- QUIT
- +2 ;
- KVAR ; kill all vadpt data
- +1 KILL VAN
- C1 KILL ^UTILITY("VADM",$JOB),VADM
- if $DATA(VAN)
- QUIT
- C01 ;DG*5.3*996
- KILL ^UTILITY("VADEMO",$JOB),VADEMO
- 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 if $DATA(VAPA("CD"))
- SET X("CD")=VAPA("CD")
- +2 KILL ^UTILITY("VAPA",$JOB),VAPA
- +3 if $DATA(X("P"))
- SET VAPA("P")=X("P")
- KILL X("P")
- +4 if $DATA(X("CD"))
- SET VAPA("CD")=X("CD")
- 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 ;
- +2 ; DG*5.3*1064 - add subscript IND to 16th piece
- +3 ; DG*5.3*1103 - TERA indicator to 15th piece of line SS+9
- +4 ; DG*5.3.1121 - add Persian Gulf Indicator to 16th piece of SS+9
- +5 ; DG*5.3*1121 - add Last Change Date of Persian Gulf Indicator to SS+9
- SS ; 1^ 2^ 3^ 4^ 5^ 6^ 7^ 8^ 9^10^11^12^13^14^15^16^17^18^19^20^21^22^23^24^25^26^27^28
- +1 ;;NM^SS^DB^AG^SX^EX^RE^RA^RP^MS^ET^RC^PL^SOGI^IND
- +2 ;;BC^BS^FN^MN^MM^OC^ES^WP
- +3 ;;L1^L2^L3^CI^ST^ZP^CO^PN^TS^TE^Z4^CCA^CL1^CL2^CL3^CCI^CST^CZP^CCO^CCS^CCE^CTY^PR^PC^CT^CPR^CPC^CCT^CPN
- +4 ;;L1^L2^L3^CI^ST^ZP^CO^PN^NM^RE^Z4
- +5 ;;AN^DR^TS^WL^RB^BS^AD^AT^AF^PT^AP
- +6 ;;MN^TT^MD^MT^WL^RB^DR^TS^MF^BS^RD^PT^AN^LN^PN^NN^DN^AP^FD
- +7 ;;EL^PS^SC^VT^IN^TY^CN^ES^MT^OTH
- +8 ;;AA^HB^SS^PE^MR^SI^DI^OR^GI
- +9 ;;VN^AO^IR^PW^CS^S1^S2^S3^PH^CV^OIF^OEF^UNK^SHD^TERA^PGI^LCD
