source: WorldVistAEHR/trunk/r/VISTA_OFFICE_EHR-VEPE/VEPER7SB.m@ 841

VEPER7SB ;RSL/DAOU HL7 EXTRACT FROM FILE SUBROUTINES; ; 8/23/05 11:30am
 ;;1.0;VISTA EHR DOQ IT HL7 extraction using Clinical Reminders; 05/20/05 ;;Build 1
REGISTER ;Write REGISTER PATIENT Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("ZRG","Z01",SF,.MSHC)
 D ZCR^VEPER7SG
 D ZPP^VEPER7SG
 D DG1^VEPER7SG
 I ALERGY D ZL1^VEPER7SG
 D ZPT^VEPER7SG
 S %DT="T",X="N" D ^%DT
 S $P(DOQREG(19904.4,DFN,TOPTYP),"^",TTP+1)=Y
 ; ****** SET THIS BACK INTO THE GLOBAL HERE *******
 Q
 ;
 ;
CANCEL ;Write CANCEL PATIENT Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("ZDL","Z02",SF,.MSHC)
 D ZCR^VEPER7SG
 D ZPP^VEPER7SG
 S %DT="T",X="N" D ^%DT
 S $P(DOQREG(19904.4,DFN,TOPTYP),"^",TTP+1)=Y
 ; *** SET THIS BACK INTO THE GLOBAL HERE ********
 Q
 ;
 ;
PTVISIT ;Write PATIENT VISIT Event Segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("ADT","A04",SF,.MSHC)
 D ZCR^VEPER7SG
 D PID^VEPER7SG
 D PV1^VEPER7SG
 ;
 ;--- Observations have to be sent for several different files
 ;-  Files to be included are:
 ;-         V MEASUREMENT (9000010.01)
 ;-         V LAB (9000010.09) Tests and results
 ;-         V EXAM (9000010.13) 
 ;-         V PATIENT EDUCATION (9000010.16) 
 ;-         V HEALTH FACTORS (9000010.23) (May not need... vitals may be in V MEASUREMENT... if so, remove this part
 ;-
 ;-   Series of loops to report these associated observations
 ;-
 N OBXC,OBX,OIEN,VOBX
 S BVDATE=9999998-EDT,EVDATE=9999999-BDT,OBXC=0
 S OBX="" F  S OBX=$O(^AUPNVMEA("AA",DFN,OBX)) Q:OBX=""  D
 .S BVDATE=$O(^AUPNVMEA("AA",DFN,OBX,BVDATE)) Q:BVDATE=""!(BVDATE>EVDATE)  D
 ..S OIEN="" F  S OIEN=$O(^AUPNVMEA("AA",DFN,OBX,BVDATE,OIEN)) Q:OIEN=""  D
 ...I $D(^TMP("VEPER7EX",$J,"MEA",DFN,OBX,BVDATE,OIEN)) Q  ;Don't process a 2nd time
 ...K VOBX D GETS^DIQ(9000010.01,OIEN_",","**","","VOBX")
 ...D GETS^DIQ(9000010.01,OIEN_",",1201,"I","VOBX")
 ...D OBX^VEPER7SG(.OBXC)
 ...S ^TMP("VEPER7EX",$J,"MEA",DFN,OBX,BVDATE,OIEN)=""
 ...K VOBX
 S BVDATE=9999998-EDT
 S OBX="" F  S OBX=$O(^AUPNVLAB("AA",DFN,OBX)) Q:OBX=""  D
 .S BVDATE=$O(^AUPNVLAB("AA",DFN,OBX,BVDATE)) Q:BVDATE=""!(BVDATE>EVDATE)  D
 ..S OIEN="" F  S OIEN=$O(^AUPNVLAB("AA",DFN,OBX,BVDATE,OIEN)) Q:OIEN=""  D
 ...I $D(^TMP("VEPER7EX",$J,"LAB",DFN,OBX,BVDATE,OIEN)) Q  ;Don't process a 2nd time
 ...K VOBX D GETS^DIQ(9000010.09,OIEN_",","**","","VOBX")
 ...D GETS^DIQ(9000010.09,OIEN_",",1201,"I","VOBX")
 ...D OBX^VEPER7SG(.OBXC)
 ...S ^TMP("VEPER7EX",$J,"LAB",DFN,OBX,BVDATE,OIEN)=""
 ...K VOBX
 S BVDATE=9999998-EDT
 S OBX="" F  S OBX=$O(^AUPNVXAM("AA",DFN,OBX)) Q:OBX=""  D
 .S BVDATE=$O(^AUPNVXAM("AA",DFN,OBX,BVDATE)) Q:BVDATE=""!(BVDATE>EVDATE)  D
 ..S OIEN="" F  S OIEN=$O(^AUPNVXAM("AA",DFN,OBX,BVDATE,OIEN)) Q:OIEN=""  D
 ...I $D(^TMP("VEPER7EX",$J,"XAM",DFN,OBX,BVDATE,OIEN)) Q  ;Don't process a 2nd time
 ...K VOBX D GETS^DIQ(9000010.13,OIEN_",","**","","VOBX")
 ...D GETS^DIQ(9000010.13,OIEN_",",1201,"I","VOBX")
 ...D OBX^VEPER7SG(.OBXC)
 ...S ^TMP("VEPER7EX",$J,"XAM",DFN,OBX,BVDATE,OIEN)=""
 ...K VOBX
 S BVDATE=9999998-EDT
 S OBX="" F  S OBX=$O(^AUPNVPED("AA",DFN,OBX)) Q:OBX=""  D
 .S BVDATE=$O(^AUPNVPED("AA",DFN,OBX,BVDATE)) Q:BVDATE=""!(BVDATE>EVDATE)  D
 ..S OIEN="" F  S OIEN=$O(^AUPNVPED("AA",DFN,OBX,BVDATE,OIEN)) Q:OIEN=""  D
 ...I $D(^TMP("VEPER7EX",$J,"PED",DFN,OBX,BVDATE,OIEN)) Q  ;Don't process a 2nd time
 ...K VOBX D GETS^DIQ(9000010.16,OIEN_",","**","","VOBX")
 ...D GETS^DIQ(9000010.16,OIEN_",",1201,"I","VOBX")
 ...D OBX^VEPER7SG(.OBXC)
 ...S ^TMP("VEPER7EX",$J,"PED",DFN,OBX,BVDATE,OIEN)=""
 ...K VOBX
 S BVDATE=9999998-EDT
 S OBX="" F  S OBX=$O(^AUPNVHF("AA",DFN,OBX)) Q:OBX=""  D
 .S BVDATE=$O(^AUPNVHF("AA",DFN,OBX,BVDATE)) Q:BVDATE=""!(BVDATE>EVDATE)  D
 ..S OIEN="" F  S OIEN=$O(^AUPNVHF("AA",DFN,OBX,BVDATE,OIEN)) Q:OIEN=""  D
 ...I $D(^TMP("VEPER7EX",$J,"HF",DFN,OBX,BVDATE,OIEN)) Q  ;Don't process a 2nd time
 ...K VOBX D GETS^DIQ(9000010.23,OIEN_",","**","","VOBX")
 ...D GETS^DIQ(9000010.23,OIEN_",",1201,"I","VOBX")
 ...D OBX^VEPER7SG(.OBXC)
 ...S ^TMP("VEPER7EX",$J,"HF",DFN,OBX,BVDATE,OIEN)=""
 ...K VOBX
 ;
 ;---  Process lab results...
 ;
 N LRDATA
 K LRDATA I VEPER7PT(2,DFN,.09)'="" D GCPR^LA7QRY(VEPER7PT(2,DFN,.09),BDT,EDT_"^RAD","*","*",.LRDATA)
 ;Loop through LRDATA to return Lab Results for DOQIT
 ;
 ;-- at this time, the array is unkown as to what it looks like.  Will
 ;-  have to add this later when there's some lab data to process.
 ;
 ;
 ;---  End of recording Observations  ----
 ;
 D DG1^VEPER7SG
 I ALERGY D ZL1^VEPER7SG
 Q
 ;
 ;
CPTVISIT ;WRITE CANCEL PATIENT VISIT Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("ADT","A11",SF,.MSHC)
 D ZCR^VEPER7SG
 D PID^VEPER7SG
 D PV1^VEPER7SG
 Q
 ;
UNSOLOM ;Write UNSOLICITED OBSERVATION Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("ORU","R01",SF,.MSHC)
 D ZCR^VEPER7SG
 D PID^VEPER7SG
 D PV1^VEPER7SG
 D ORC^VEPER7SG
 D OBR^VEPER7SG
 D OBX^VEPER7SG
 Q
 ;
 ;
PXTRTOM ;Write PHARMACY/TREATMENT ORDER Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("OMP","O09",SF,.MSHC)
 D ZCR^VEPER7SG
 D PID^VEPER7SG
 D PV1^VEPER7SG
 D ORC^VEPER7SG
 D RXO^VEPER7SG
 Q
 ;
 ;
VAXMSG ;Write VACCINATION MESSAGE Event segments
 ;
 I 'FHSC D FHS^VEPER7SG(SF,.FHSC,.BHSC,PROD,HL7DIR_HL7FN,FNMID)
 I 'BHSC D BHS^VEPER7SG(SF,.BHSC,.MSHC)
 D MSH^VEPER7SG("VXU","V04",SV,.MSHC)
 D ZCR^VEPER7SG
 D PID^VEPER7SG
 ;
 ;
 ;----  Fetch physician and clinic information
 N PRIPHN,INST,PIEN
 D GETS^DIQ(9000010.11,VIMMIEN_",",1202,"I","PRIPHN")
 S PIEN=$G(PRIPHN(9000010.11,VIMMIEN_",",1204))_","
 D GETS^DIQ(200,PIEN,"16;53.2","","INST")
 I $G(INST(200,PIEN,16))="" S INST(200,PIEN,16)=SF
 ;
 ;
 D ORC^VEPER7SG
 D RXA^VEPER7SG(.RXAC)
 Q
 ;
 ;