Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAQDBIP6

VAQDBIP6.m

Go to the documentation of this file.
  1. VAQDBIP6 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP4;25-MAR-93
  1. ;;1.5;PATIENT DATA EXCHANGE;**41**;NOV 17, 1993
  1. ELIG ;EXTRACT ELIGIBILITIES
  1. ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
  1. S TMP=$T(ELIG+1^VAQDBII1)
  1. S FLDS=$TR($P(TMP,";",4),",",";")
  1. ;ENCRYPT PATIENT NAME
  1. S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
  1. S ENCSTR=STRING
  1. I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
  1. S NAME=ENCSTR
  1. ;DETERMINE PRIMARY ELIGIBILITY
  1. S DIC="^DPT("
  1. S DA=DFN
  1. S DR=.361
  1. S DIQ(0)="E"
  1. K ^UTILITY("DIQ1",$J)
  1. D EN^DIQ1
  1. S PRIME=$G(^UTILITY("DIQ1",$J,2,DFN,.361,"E"))
  1. ;GET OTHER ELIGIBILITIES
  1. S TMP=0
  1. F S TMP=$O(^DPT(DFN,"E",TMP)) Q:('TMP) D
  1. .S DIC="^DPT("
  1. .S DA=DFN
  1. .S DR=361
  1. .S DIQ(0)="E"
  1. .S DA(2.0361)=TMP
  1. .S DR(2.0361)=FLDS
  1. .K ^UTILITY("DIQ1",$J)
  1. .D EN^DIQ1
  1. .;SCREEN OUT PRIMARY ELIGIBILITY
  1. .S Y=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),.01,"E"))
  1. .Q:(Y=PRIME)
  1. .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.0361,.01)
  1. .;ENCRYPT VALUE
  1. .S STRING=Y
  1. .S ENCSTR=STRING
  1. .I $$NCRPFLD^VAQUTL2(2.0361,.01) X ENCRYPT
  1. .S @ARRAY@("ID",2.0361,.01,SEQ)=NAME
  1. .S @ARRAY@("VALUE",2.0361,.01,SEQ)=ENCSTR
  1. .S Y=ENCSTR
  1. .;MOVE INFORMATION INTO EXTRACTION ARRAY
  1. .F X=1:1:$L(FLDS,";") D
  1. ..S Z=$P(FLDS,";",X)
  1. ..;STORE ID
  1. ..S @ARRAY@("ID",2.0361,Z,SEQ)=Y
  1. ..;ENCRYPT VALUE
  1. ..S STRING=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),Z,"E"))
  1. ..S ENCSTR=STRING
  1. ..I $$NCRPFLD^VAQUTL2(2.0361,Z) X ENCRYPT
  1. ..S @ARRAY@("VALUE",2.0361,Z,SEQ)=ENCSTR
  1. .K ^UTILITY("DIQ1",$J)
  1. Q
  1. ;
  1. APPOINT ;EXTRACT APPOINTMENTS
  1. N VAQDT
  1. ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
  1. S TMP=$T(APPOINT+1^VAQDBII1)
  1. S FLDS=$TR($P(TMP,";",4),",",";")
  1. ;ENCRYPT PATIENT NAME
  1. S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
  1. S ENCSTR=STRING
  1. I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
  1. S NAME=ENCSTR
  1. D APPGET ; Get last 5 appointments
  1. S VAQDT="" ; Process in reverse order
  1. F VAQDT=$O(^UTILITY("DIQ1",$J,2.98,VAQDT),-1) Q:VAQDT="" D
  1. .S Y=VAQDT D DD^%DT
  1. .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.98,.001)
  1. .;ENCRYPT VALUE
  1. .S STRING=Y
  1. .S ENCSTR=STRING
  1. .I $$NCRPFLD^VAQUTL2(2.98,.001) X ENCRYPT
  1. .S @ARRAY@("ID",2.98,.001,SEQ)=NAME
  1. .S @ARRAY@("VALUE",2.98,.001,SEQ)=ENCSTR
  1. .S Y=ENCSTR
  1. .;MOVE INFORMATION INTO EXTRACTION ARRAY
  1. .F X=1:1:$L(FLDS,";") D
  1. ..S Z=$P(FLDS,";",X)
  1. ..;STORE ID
  1. ..S @ARRAY@("ID",2.98,Z,SEQ)=Y
  1. ..;ENCRYPT VALUE
  1. ..S STRING=$G(^UTILITY("DIQ1",$J,2.98,VAQDT,Z,"E"))
  1. ..S ENCSTR=STRING
  1. ..I $$NCRPFLD^VAQUTL2(2.98,Z) X ENCRYPT
  1. ..S @ARRAY@("VALUE",2.98,Z,SEQ)=ENCSTR
  1. K ^UTILITY("DIQ1",$J)
  1. Q
  1. APPGET ; Get last 5 appointments.
  1. ; Prior to patch *41, we retrieved data directly from the APPOINTMENTS
  1. ; subfile (#2.98) of the PATIENT file. Now, we retrieve using the new
  1. ; Scheduling Replacement API from a central database.
  1. ; Fields requested:
  1. ; Old Description New
  1. ; --- ---------------- ---
  1. ; .001 Appt date/time 1
  1. ; .01 Clinic 2
  1. ; 3 Status 3
  1. ; 9 Purpose of Visit 18
  1. ; 9.5 Appt type 10
  1. N X,VAQSD,VAQDT,VAQREC
  1. S VAQSD(4)=DFN
  1. S VAQSD("FLDS")="1;2;3;18;10"
  1. S VAQSD("SORT")="P" ; Sort by patient only (not clinic)
  1. S VAQSD("MAX")=-5 ; Return last 5 appts.
  1. S X=$$SDAPI^SDAMA301(.VAQSD)
  1. ; For each of the last 5 appts, move to Utility global,
  1. ; with VAQDT being the date/time of the appt.
  1. K ^UTILITY("DIQ1",$J)
  1. S VAQDT=""
  1. F S VAQDT=$O(^TMP($J,"SDAMA301",DFN,VAQDT)) Q:VAQDT="" S VAQREC=^(VAQDT) D
  1. . S ^UTILITY("DIQ1",$J,2.98,VAQDT,.01,"E")=$P($P(VAQREC,U,2),";",2)
  1. . S ^UTILITY("DIQ1",$J,2.98,VAQDT,3,"E")=$P($P(VAQREC,U,3),";",2)
  1. . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9,"E")=$P($P(VAQREC,U,18),";",2)
  1. . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9.5,"E")=$P($P(VAQREC,U,10),";",2)
  1. K ^TMP($J,"SDAMA301")
  1. Q
  1. ;
  1. DENTAL ;EXTRACT DENTAL APPOINTMENTS
  1. ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
  1. S TMP=$T(DENTAL+1^VAQDBII1)
  1. S FLDS=$TR($P(TMP,";",4),",",";")
  1. ;ENCRYPT PATIENT NAME
  1. S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
  1. S ENCSTR=STRING
  1. I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
  1. S NAME=ENCSTR
  1. ;PUT DENTAL APPOINTMENTS IN REVERS ORDER
  1. S TMP=0
  1. K ^TMP("VAQ",$J,$J)
  1. F S TMP=$O(^DPT(DFN,.37,TMP)) Q:('TMP) D
  1. .S X=+$G(^DPT(DFN,.37,TMP,0))
  1. .Q:('X)
  1. .S ^TMP("VAQ",$J,$J,(9999999-X))=TMP_"^"_X
  1. S TMP=""
  1. ;EXTRACT 5 DENTAL APPOINTMENTS
  1. F LOOP=1:1:5 S TMP=$O(^TMP("VAQ",$J,$J,TMP)) Q:(TMP="") D
  1. .S DIC="^DPT("
  1. .S DA=DFN
  1. .S DR=.37
  1. .S DIQ(0)="E"
  1. .S DA(2.11)=+^TMP("VAQ",$J,$J,TMP)
  1. .S DR(2.11)=FLDS
  1. .K ^UTILITY("DIQ1",$J)
  1. .D EN^DIQ1
  1. .;MOVE DATE OF DENTAL APPOINTMENT INTO EXTRACTION ARRAY
  1. .S Y=+$P(^TMP("VAQ",$J,$J,TMP),"^",2) D DD^%DT
  1. .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.11,.01)
  1. .;ENCRYPT VALUE
  1. .S STRING=Y
  1. .S ENCSTR=STRING
  1. .I $$NCRPFLD^VAQUTL2(2.11,.01) X ENCRYPT
  1. .S @ARRAY@("ID",2.11,.01,SEQ)=NAME
  1. .S @ARRAY@("VALUE",2.11,.01,SEQ)=ENCSTR
  1. .S Y=STRING
  1. .;MOVE INFO INTO EXTRACTION ARRAY
  1. .F X=1:1:$L(FLDS,";") D
  1. ..S Z=$P(FLDS,";",X)
  1. ..Q:(Z=.01)
  1. ..;STORE ID
  1. ..S @ARRAY@("ID",2.11,Z,SEQ)=Y
  1. ..;ENCRYPT VALUE
  1. ..S STRING=$G(^UTILITY("DIQ1",$J,2.11,DA(2.11),Z,"E"))
  1. ..S ENCSTR=STRING
  1. ..I $$NCRPFLD^VAQUTL2(2.11,Z) X ENCRYPT
  1. ..S @ARRAY@("VALUE",2.11,Z,SEQ)=ENCSTR
  1. .K ^UTILITY("DIQ1",$J)
  1. K ^TMP("VAQ",$J,$J)
  1. Q