- VAQDBIP6 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP4;25-MAR-93
- ;;1.5;PATIENT DATA EXCHANGE;**41**;NOV 17, 1993
- ELIG ;EXTRACT ELIGIBILITIES
- ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- S TMP=$T(ELIG+1^VAQDBII1)
- S FLDS=$TR($P(TMP,";",4),",",";")
- ;ENCRYPT PATIENT NAME
- S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
- S ENCSTR=STRING
- I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
- S NAME=ENCSTR
- ;DETERMINE PRIMARY ELIGIBILITY
- S DIC="^DPT("
- S DA=DFN
- S DR=.361
- S DIQ(0)="E"
- K ^UTILITY("DIQ1",$J)
- D EN^DIQ1
- S PRIME=$G(^UTILITY("DIQ1",$J,2,DFN,.361,"E"))
- ;GET OTHER ELIGIBILITIES
- S TMP=0
- F S TMP=$O(^DPT(DFN,"E",TMP)) Q:('TMP) D
- .S DIC="^DPT("
- .S DA=DFN
- .S DR=361
- .S DIQ(0)="E"
- .S DA(2.0361)=TMP
- .S DR(2.0361)=FLDS
- .K ^UTILITY("DIQ1",$J)
- .D EN^DIQ1
- .;SCREEN OUT PRIMARY ELIGIBILITY
- .S Y=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),.01,"E"))
- .Q:(Y=PRIME)
- .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.0361,.01)
- .;ENCRYPT VALUE
- .S STRING=Y
- .S ENCSTR=STRING
- .I $$NCRPFLD^VAQUTL2(2.0361,.01) X ENCRYPT
- .S @ARRAY@("ID",2.0361,.01,SEQ)=NAME
- .S @ARRAY@("VALUE",2.0361,.01,SEQ)=ENCSTR
- .S Y=ENCSTR
- .;MOVE INFORMATION INTO EXTRACTION ARRAY
- .F X=1:1:$L(FLDS,";") D
- ..S Z=$P(FLDS,";",X)
- ..;STORE ID
- ..S @ARRAY@("ID",2.0361,Z,SEQ)=Y
- ..;ENCRYPT VALUE
- ..S STRING=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),Z,"E"))
- ..S ENCSTR=STRING
- ..I $$NCRPFLD^VAQUTL2(2.0361,Z) X ENCRYPT
- ..S @ARRAY@("VALUE",2.0361,Z,SEQ)=ENCSTR
- .K ^UTILITY("DIQ1",$J)
- Q
- ;
- APPOINT ;EXTRACT APPOINTMENTS
- N VAQDT
- ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- S TMP=$T(APPOINT+1^VAQDBII1)
- S FLDS=$TR($P(TMP,";",4),",",";")
- ;ENCRYPT PATIENT NAME
- S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
- S ENCSTR=STRING
- I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
- S NAME=ENCSTR
- D APPGET ; Get last 5 appointments
- S VAQDT="" ; Process in reverse order
- F VAQDT=$O(^UTILITY("DIQ1",$J,2.98,VAQDT),-1) Q:VAQDT="" D
- .S Y=VAQDT D DD^%DT
- .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.98,.001)
- .;ENCRYPT VALUE
- .S STRING=Y
- .S ENCSTR=STRING
- .I $$NCRPFLD^VAQUTL2(2.98,.001) X ENCRYPT
- .S @ARRAY@("ID",2.98,.001,SEQ)=NAME
- .S @ARRAY@("VALUE",2.98,.001,SEQ)=ENCSTR
- .S Y=ENCSTR
- .;MOVE INFORMATION INTO EXTRACTION ARRAY
- .F X=1:1:$L(FLDS,";") D
- ..S Z=$P(FLDS,";",X)
- ..;STORE ID
- ..S @ARRAY@("ID",2.98,Z,SEQ)=Y
- ..;ENCRYPT VALUE
- ..S STRING=$G(^UTILITY("DIQ1",$J,2.98,VAQDT,Z,"E"))
- ..S ENCSTR=STRING
- ..I $$NCRPFLD^VAQUTL2(2.98,Z) X ENCRYPT
- ..S @ARRAY@("VALUE",2.98,Z,SEQ)=ENCSTR
- K ^UTILITY("DIQ1",$J)
- Q
- APPGET ; Get last 5 appointments.
- ; Prior to patch *41, we retrieved data directly from the APPOINTMENTS
- ; subfile (#2.98) of the PATIENT file. Now, we retrieve using the new
- ; Scheduling Replacement API from a central database.
- ; Fields requested:
- ; Old Description New
- ; --- ---------------- ---
- ; .001 Appt date/time 1
- ; .01 Clinic 2
- ; 3 Status 3
- ; 9 Purpose of Visit 18
- ; 9.5 Appt type 10
- N X,VAQSD,VAQDT,VAQREC
- S VAQSD(4)=DFN
- S VAQSD("FLDS")="1;2;3;18;10"
- S VAQSD("SORT")="P" ; Sort by patient only (not clinic)
- S VAQSD("MAX")=-5 ; Return last 5 appts.
- S X=$$SDAPI^SDAMA301(.VAQSD)
- ; For each of the last 5 appts, move to Utility global,
- ; with VAQDT being the date/time of the appt.
- K ^UTILITY("DIQ1",$J)
- S VAQDT=""
- F S VAQDT=$O(^TMP($J,"SDAMA301",DFN,VAQDT)) Q:VAQDT="" S VAQREC=^(VAQDT) D
- . S ^UTILITY("DIQ1",$J,2.98,VAQDT,.01,"E")=$P($P(VAQREC,U,2),";",2)
- . S ^UTILITY("DIQ1",$J,2.98,VAQDT,3,"E")=$P($P(VAQREC,U,3),";",2)
- . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9,"E")=$P($P(VAQREC,U,18),";",2)
- . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9.5,"E")=$P($P(VAQREC,U,10),";",2)
- K ^TMP($J,"SDAMA301")
- Q
- ;
- DENTAL ;EXTRACT DENTAL APPOINTMENTS
- ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- S TMP=$T(DENTAL+1^VAQDBII1)
- S FLDS=$TR($P(TMP,";",4),",",";")
- ;ENCRYPT PATIENT NAME
- S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
- S ENCSTR=STRING
- I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
- S NAME=ENCSTR
- ;PUT DENTAL APPOINTMENTS IN REVERS ORDER
- S TMP=0
- K ^TMP("VAQ",$J,$J)
- F S TMP=$O(^DPT(DFN,.37,TMP)) Q:('TMP) D
- .S X=+$G(^DPT(DFN,.37,TMP,0))
- .Q:('X)
- .S ^TMP("VAQ",$J,$J,(9999999-X))=TMP_"^"_X
- S TMP=""
- ;EXTRACT 5 DENTAL APPOINTMENTS
- F LOOP=1:1:5 S TMP=$O(^TMP("VAQ",$J,$J,TMP)) Q:(TMP="") D
- .S DIC="^DPT("
- .S DA=DFN
- .S DR=.37
- .S DIQ(0)="E"
- .S DA(2.11)=+^TMP("VAQ",$J,$J,TMP)
- .S DR(2.11)=FLDS
- .K ^UTILITY("DIQ1",$J)
- .D EN^DIQ1
- .;MOVE DATE OF DENTAL APPOINTMENT INTO EXTRACTION ARRAY
- .S Y=+$P(^TMP("VAQ",$J,$J,TMP),"^",2) D DD^%DT
- .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.11,.01)
- .;ENCRYPT VALUE
- .S STRING=Y
- .S ENCSTR=STRING
- .I $$NCRPFLD^VAQUTL2(2.11,.01) X ENCRYPT
- .S @ARRAY@("ID",2.11,.01,SEQ)=NAME
- .S @ARRAY@("VALUE",2.11,.01,SEQ)=ENCSTR
- .S Y=STRING
- .;MOVE INFO INTO EXTRACTION ARRAY
- .F X=1:1:$L(FLDS,";") D
- ..S Z=$P(FLDS,";",X)
- ..Q:(Z=.01)
- ..;STORE ID
- ..S @ARRAY@("ID",2.11,Z,SEQ)=Y
- ..;ENCRYPT VALUE
- ..S STRING=$G(^UTILITY("DIQ1",$J,2.11,DA(2.11),Z,"E"))
- ..S ENCSTR=STRING
- ..I $$NCRPFLD^VAQUTL2(2.11,Z) X ENCRYPT
- ..S @ARRAY@("VALUE",2.11,Z,SEQ)=ENCSTR
- .K ^UTILITY("DIQ1",$J)
- K ^TMP("VAQ",$J,$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP6 5195 printed Feb 18, 2025@23:51:16 Page 2
- VAQDBIP6 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP4;25-MAR-93
- +1 ;;1.5;PATIENT DATA EXCHANGE;**41**;NOV 17, 1993
- ELIG ;EXTRACT ELIGIBILITIES
- +1 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- +2 SET TMP=$TEXT(ELIG+1^VAQDBII1)
- +3 SET FLDS=$TRANSLATE($PIECE(TMP,";",4),",",";")
- +4 ;ENCRYPT PATIENT NAME
- +5 SET STRING=$PIECE($$PATINFO^VAQUTL1(DFN),"^",1)
- +6 SET ENCSTR=STRING
- +7 IF $$NCRPFLD^VAQUTL2(2,.01)
- XECUTE ENCRYPT
- +8 SET NAME=ENCSTR
- +9 ;DETERMINE PRIMARY ELIGIBILITY
- +10 SET DIC="^DPT("
- +11 SET DA=DFN
- +12 SET DR=.361
- +13 SET DIQ(0)="E"
- +14 KILL ^UTILITY("DIQ1",$JOB)
- +15 DO EN^DIQ1
- +16 SET PRIME=$GET(^UTILITY("DIQ1",$JOB,2,DFN,.361,"E"))
- +17 ;GET OTHER ELIGIBILITIES
- +18 SET TMP=0
- +19 FOR
- SET TMP=$ORDER(^DPT(DFN,"E",TMP))
- if ('TMP)
- QUIT
- Begin DoDot:1
- +20 SET DIC="^DPT("
- +21 SET DA=DFN
- +22 SET DR=361
- +23 SET DIQ(0)="E"
- +24 SET DA(2.0361)=TMP
- +25 SET DR(2.0361)=FLDS
- +26 KILL ^UTILITY("DIQ1",$JOB)
- +27 DO EN^DIQ1
- +28 ;SCREEN OUT PRIMARY ELIGIBILITY
- +29 SET Y=$GET(^UTILITY("DIQ1",$JOB,2.0361,DA(2.0361),.01,"E"))
- +30 if (Y=PRIME)
- QUIT
- +31 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.0361,.01)
- +32 ;ENCRYPT VALUE
- +33 SET STRING=Y
- +34 SET ENCSTR=STRING
- +35 IF $$NCRPFLD^VAQUTL2(2.0361,.01)
- XECUTE ENCRYPT
- +36 SET @ARRAY@("ID",2.0361,.01,SEQ)=NAME
- +37 SET @ARRAY@("VALUE",2.0361,.01,SEQ)=ENCSTR
- +38 SET Y=ENCSTR
- +39 ;MOVE INFORMATION INTO EXTRACTION ARRAY
- +40 FOR X=1:1:$LENGTH(FLDS,";")
- Begin DoDot:2
- +41 SET Z=$PIECE(FLDS,";",X)
- +42 ;STORE ID
- +43 SET @ARRAY@("ID",2.0361,Z,SEQ)=Y
- +44 ;ENCRYPT VALUE
- +45 SET STRING=$GET(^UTILITY("DIQ1",$JOB,2.0361,DA(2.0361),Z,"E"))
- +46 SET ENCSTR=STRING
- +47 IF $$NCRPFLD^VAQUTL2(2.0361,Z)
- XECUTE ENCRYPT
- +48 SET @ARRAY@("VALUE",2.0361,Z,SEQ)=ENCSTR
- End DoDot:2
- +49 KILL ^UTILITY("DIQ1",$JOB)
- End DoDot:1
- +50 QUIT
- +51 ;
- APPOINT ;EXTRACT APPOINTMENTS
- +1 NEW VAQDT
- +2 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- +3 SET TMP=$TEXT(APPOINT+1^VAQDBII1)
- +4 SET FLDS=$TRANSLATE($PIECE(TMP,";",4),",",";")
- +5 ;ENCRYPT PATIENT NAME
- +6 SET STRING=$PIECE($$PATINFO^VAQUTL1(DFN),"^",1)
- +7 SET ENCSTR=STRING
- +8 IF $$NCRPFLD^VAQUTL2(2,.01)
- XECUTE ENCRYPT
- +9 SET NAME=ENCSTR
- +10 ; Get last 5 appointments
- DO APPGET
- +11 ; Process in reverse order
- SET VAQDT=""
- +12 FOR VAQDT=$ORDER(^UTILITY("DIQ1",$JOB,2.98,VAQDT),-1)
- if VAQDT=""
- QUIT
- Begin DoDot:1
- +13 SET Y=VAQDT
- DO DD^%DT
- +14 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.98,.001)
- +15 ;ENCRYPT VALUE
- +16 SET STRING=Y
- +17 SET ENCSTR=STRING
- +18 IF $$NCRPFLD^VAQUTL2(2.98,.001)
- XECUTE ENCRYPT
- +19 SET @ARRAY@("ID",2.98,.001,SEQ)=NAME
- +20 SET @ARRAY@("VALUE",2.98,.001,SEQ)=ENCSTR
- +21 SET Y=ENCSTR
- +22 ;MOVE INFORMATION INTO EXTRACTION ARRAY
- +23 FOR X=1:1:$LENGTH(FLDS,";")
- Begin DoDot:2
- +24 SET Z=$PIECE(FLDS,";",X)
- +25 ;STORE ID
- +26 SET @ARRAY@("ID",2.98,Z,SEQ)=Y
- +27 ;ENCRYPT VALUE
- +28 SET STRING=$GET(^UTILITY("DIQ1",$JOB,2.98,VAQDT,Z,"E"))
- +29 SET ENCSTR=STRING
- +30 IF $$NCRPFLD^VAQUTL2(2.98,Z)
- XECUTE ENCRYPT
- +31 SET @ARRAY@("VALUE",2.98,Z,SEQ)=ENCSTR
- End DoDot:2
- End DoDot:1
- +32 KILL ^UTILITY("DIQ1",$JOB)
- +33 QUIT
- APPGET ; Get last 5 appointments.
- +1 ; Prior to patch *41, we retrieved data directly from the APPOINTMENTS
- +2 ; subfile (#2.98) of the PATIENT file. Now, we retrieve using the new
- +3 ; Scheduling Replacement API from a central database.
- +4 ; Fields requested:
- +5 ; Old Description New
- +6 ; --- ---------------- ---
- +7 ; .001 Appt date/time 1
- +8 ; .01 Clinic 2
- +9 ; 3 Status 3
- +10 ; 9 Purpose of Visit 18
- +11 ; 9.5 Appt type 10
- +12 NEW X,VAQSD,VAQDT,VAQREC
- +13 SET VAQSD(4)=DFN
- +14 SET VAQSD("FLDS")="1;2;3;18;10"
- +15 ; Sort by patient only (not clinic)
- SET VAQSD("SORT")="P"
- +16 ; Return last 5 appts.
- SET VAQSD("MAX")=-5
- +17 SET X=$$SDAPI^SDAMA301(.VAQSD)
- +18 ; For each of the last 5 appts, move to Utility global,
- +19 ; with VAQDT being the date/time of the appt.
- +20 KILL ^UTILITY("DIQ1",$JOB)
- +21 SET VAQDT=""
- +22 FOR
- SET VAQDT=$ORDER(^TMP($JOB,"SDAMA301",DFN,VAQDT))
- if VAQDT=""
- QUIT
- SET VAQREC=^(VAQDT)
- Begin DoDot:1
- +23 SET ^UTILITY("DIQ1",$JOB,2.98,VAQDT,.01,"E")=$PIECE($PIECE(VAQREC,U,2),";",2)
- +24 SET ^UTILITY("DIQ1",$JOB,2.98,VAQDT,3,"E")=$PIECE($PIECE(VAQREC,U,3),";",2)
- +25 SET ^UTILITY("DIQ1",$JOB,2.98,VAQDT,9,"E")=$PIECE($PIECE(VAQREC,U,18),";",2)
- +26 SET ^UTILITY("DIQ1",$JOB,2.98,VAQDT,9.5,"E")=$PIECE($PIECE(VAQREC,U,10),";",2)
- End DoDot:1
- +27 KILL ^TMP($JOB,"SDAMA301")
- +28 QUIT
- +29 ;
- DENTAL ;EXTRACT DENTAL APPOINTMENTS
- +1 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
- +2 SET TMP=$TEXT(DENTAL+1^VAQDBII1)
- +3 SET FLDS=$TRANSLATE($PIECE(TMP,";",4),",",";")
- +4 ;ENCRYPT PATIENT NAME
- +5 SET STRING=$PIECE($$PATINFO^VAQUTL1(DFN),"^",1)
- +6 SET ENCSTR=STRING
- +7 IF $$NCRPFLD^VAQUTL2(2,.01)
- XECUTE ENCRYPT
- +8 SET NAME=ENCSTR
- +9 ;PUT DENTAL APPOINTMENTS IN REVERS ORDER
- +10 SET TMP=0
- +11 KILL ^TMP("VAQ",$JOB,$JOB)
- +12 FOR
- SET TMP=$ORDER(^DPT(DFN,.37,TMP))
- if ('TMP)
- QUIT
- Begin DoDot:1
- +13 SET X=+$GET(^DPT(DFN,.37,TMP,0))
- +14 if ('X)
- QUIT
- +15 SET ^TMP("VAQ",$JOB,$JOB,(9999999-X))=TMP_"^"_X
- End DoDot:1
- +16 SET TMP=""
- +17 ;EXTRACT 5 DENTAL APPOINTMENTS
- +18 FOR LOOP=1:1:5
- SET TMP=$ORDER(^TMP("VAQ",$JOB,$JOB,TMP))
- if (TMP="")
- QUIT
- Begin DoDot:1
- +19 SET DIC="^DPT("
- +20 SET DA=DFN
- +21 SET DR=.37
- +22 SET DIQ(0)="E"
- +23 SET DA(2.11)=+^TMP("VAQ",$JOB,$JOB,TMP)
- +24 SET DR(2.11)=FLDS
- +25 KILL ^UTILITY("DIQ1",$JOB)
- +26 DO EN^DIQ1
- +27 ;MOVE DATE OF DENTAL APPOINTMENT INTO EXTRACTION ARRAY
- +28 SET Y=+$PIECE(^TMP("VAQ",$JOB,$JOB,TMP),"^",2)
- DO DD^%DT
- +29 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.11,.01)
- +30 ;ENCRYPT VALUE
- +31 SET STRING=Y
- +32 SET ENCSTR=STRING
- +33 IF $$NCRPFLD^VAQUTL2(2.11,.01)
- XECUTE ENCRYPT
- +34 SET @ARRAY@("ID",2.11,.01,SEQ)=NAME
- +35 SET @ARRAY@("VALUE",2.11,.01,SEQ)=ENCSTR
- +36 SET Y=STRING
- +37 ;MOVE INFO INTO EXTRACTION ARRAY
- +38 FOR X=1:1:$LENGTH(FLDS,";")
- Begin DoDot:2
- +39 SET Z=$PIECE(FLDS,";",X)
- +40 if (Z=.01)
- QUIT
- +41 ;STORE ID
- +42 SET @ARRAY@("ID",2.11,Z,SEQ)=Y
- +43 ;ENCRYPT VALUE
- +44 SET STRING=$GET(^UTILITY("DIQ1",$JOB,2.11,DA(2.11),Z,"E"))
- +45 SET ENCSTR=STRING
- +46 IF $$NCRPFLD^VAQUTL2(2.11,Z)
- XECUTE ENCRYPT
- +47 SET @ARRAY@("VALUE",2.11,Z,SEQ)=ENCSTR
- End DoDot:2
- +48 KILL ^UTILITY("DIQ1",$JOB)
- End DoDot:1
- +49 KILL ^TMP("VAQ",$JOB,$JOB)
- +50 QUIT