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 Oct 16, 2024@18:25:57 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
