- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m
r613 r623 1 ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002 2 ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ;This routine will intercept the HL7 message that it sent from Pharmacy 5 ;to CPRS to update order information. The message is then parsed and 6 ;repackage so it can be sent to the BCBU workstation. 7 ; 8 ; Reference/IA 9 ; EN^PSJBCBU/3876 10 ; $$EN^VAFHLPID/263 11 ; $$EN^VAFHAPV1/4512 12 ; EN1^GMRADPT/10099 13 ; EN^PSJBCMA1/2829 14 ; 15 IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY 16 N VAIN,ALPMSG 17 S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG") 18 I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array" 19 S MSH=0 20 F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH" 21 I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message" 22 S MSFS=$E(@ALPMSG@(MSH),4,4) 23 S MSCS=$E(@ALPMSG@(MSH),5,5) 24 S MSCH=$E(@ALPMSG@(MSH),6,6) 25 S MSCTR=$E(@ALPMSG@(MSH),4,8) 26 ;The message is confirmed to be a Pharmacy message 27 I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message" 28 ;A PID and PV1 segment is required for this message 29 S PID=0 30 F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID" 31 I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message" 32 ;Also the patient must have an inpatient status 33 S PV1=0 34 F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1" 35 I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message" 36 I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message" 37 S ORC=0 38 F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC" 39 I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message" 40 ;RE-BUILDING THE MESSAGE FOR BCBU 41 S ALPDFN=$P(@ALPMSG@(PID),MSFS,4) 42 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" 43 S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1) 44 I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC" 45 K ALPB 46 D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB) 47 SEED ;Entry point for ^ALPBIND 48 N VAIN 49 D INIT 50 S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D 51 . ;convert and move the message to the HLA array for transport 52 . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB)) 53 . ;Now check for continuations 54 . S SUB1=0 55 . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D 56 . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1)) 57 . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB 58 . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB 59 . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB 60 K HLA("HLS",MSH) 61 I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message" 62 S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1) 63 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" 64 S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 65 ;Fix RXE segement for Administration Type 66 D RXE 67 ;Get the Division that the patient is associated with 68 D PDIV 69 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" 70 I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV 71 ;SET NEW PV1 72 D NOW^%DTC 73 S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18") 74 S HLA("HLS",PV1)=STRING 75 I +ORC>0 D 76 . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6)) 77 . Q:ALPST="" 78 . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST 79 D AL1 80 ;Capture message to review for testing before sending 81 D SEND 82 EXIT ;EXIT and kill 83 K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR 84 K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN 85 K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST 86 K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL 87 Q ALPRSLT 88 INI() ;INTIAL SET UP ENTRY 89 G SEED 90 INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES 91 ;SET UP ENVIRONMENT FOR MESSAGE 92 K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS 93 S EVENT="PSB BCBU ORM SEND" 94 D INIT^HLFNC2(EVENT,.HL,1) 95 S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH") 96 Q 97 SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE 98 K ALPRSLT,ALPOPTS 99 D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS) 100 Q 101 AL1 ;ALLERGY SEGMENT BUILD 102 ;The will build the ALP segment with the curent allergies 103 ;for the patient to be added to the message 104 N DFN 105 Q:+ALPDFN'>0 106 K GMRAL 107 S DFN=ALPDFN 108 S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN 109 D EN1^GMRADPT 110 Q:'$D(GMRAL) 111 S ALPI=0,ALPC=1,ALPSYM="" 112 F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D 113 . S ALPADR="" 114 . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** " 115 . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7) 116 . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8" 117 . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D 118 . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS 119 . ;S $P(ALPDATA,HLFS,6)=ALPSYM 120 . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA 121 . S ALPC=ALPC+1 122 K GMRAL 123 Q 124 RXE ; 125 Q:+$G(RXE)'>0 126 K ^TMP("PSJ1",$J) 127 Q:'$D(HLA("HLS",RXE)) 128 S DATA=HLA("HLS",RXE) 129 D EN^PSJBCMA1(ALPDFN,ALPORD,1) 130 S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2) 131 Q:TYP="CONTINUOUS" 132 Q:TYP="FILL ON REQUEST" 133 S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2) 134 I ALP1[TYP Q 135 I ALP2[TYP Q 136 S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP 137 S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1 138 S HLA("HLS",RXE)=DATA 139 K TYP,ALP1,ALP2,^TMP("PSJ1",$J) 140 Q 141 PDIV ;PATIENT DIVISION 142 ;Check ALPBMDT Variable 143 S:+$G(ALPBMDT)'>0 ALPBMDT=0 144 S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT) 145 ;Screen Dom 146 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q 147 ;Now do I send the Message or not Based of Division 148 I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS") 149 I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV) 150 Q 151 MEDL(ALPML) ;Use this entry to send MedLog messages 152 N VAIN 153 ;ALPML is the IEN of the MedLog for file #53.79 154 I '$D(ALPML) Q "0^ALPML^No Med-Log Number" 155 I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid" 156 ;First get the required HL7 Variables 157 D INIT 158 ;Need to build the PID, PV1 and ORC segments 159 S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1) 160 I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log" 161 ;Get the Division that the patient is associated with 162 D PDIV 163 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" 164 I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log" 165 S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9) 166 S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7) 167 S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) 168 S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1) 169 S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1) 170 S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non") 171 I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log" 172 S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 173 I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log" 174 S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 175 I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log" 176 S HLA("HLS",1)=PID 177 S HLA("HLS",2)=PV1 178 ;BUILD ORC SEGMENT 179 S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS 180 S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS 181 S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN 182 S HLA("HLS",3)=ORC 183 ;The Message is ready to send 184 D SEND 185 Q ALPRSLT 186 ; 187 ADMQ ;Need to que a single patient init for admissions 188 S ALDFN=ALPDFN 189 S ZTDTH=$$NOW^XLFDT 190 S ZTRTN="PAT^ALPBIND" 191 S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation" 192 S ZTIO="",ZTSAVE("ALDFN")="" 193 D ^%ZTLOAD 194 K ZTIO,ZTDESC,ZTRTN,ZTSK 195 Q 196 PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement 197 N VAIN 198 I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID" 199 D INIT 200 ;Check Movement type. If not a discharge then don't pass date and time 201 S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0 202 ;Get the Division that the patient is associated with 203 D PDIV 204 I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY" 205 I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move" 206 S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 207 S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 208 S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP) 209 D SEND 210 I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH 211 I $G(ALPTT)="ADMISSION" D ADMQ 212 ;SEND A DISCHARGE TO DIV SENDING ASIH 213 I $G(ALPTYP)[13!($G(ALPTYP)[40) D 214 .D INIT 215 .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD 216 .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD 217 .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) 218 .D GET^ALPBPARM(.HLL,ALPBDIV) 219 .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 220 .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 221 .S $P(HLA("HLS",2),HLFS,37)="ASIH" 222 .D SEND 223 Q ALPRSLT 1 ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002 2 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004 3 ;This routine will intercept the HL7 message that it sent from Pharmacy 4 ;to CPRS to update order information. The message is then parsed and 5 ;repackage so it can be sent to the BCBU workstation. 6 ; 7 ; Reference/IA 8 ; EN^PSJBCBU/3876 9 ; $$EN^VAFHLPID/263 10 ; $$EN^VAFHAPV1/4512 11 ; EN1^GMRADPT/10099 12 ; EN^PSJBCMA1/2829 13 ; 14 IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY 15 N VAIN,ALPMSG 16 S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG") 17 I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array" 18 S MSH=0 19 F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH" 20 I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message" 21 S MSFS=$E(@ALPMSG@(MSH),4,4) 22 S MSCS=$E(@ALPMSG@(MSH),5,5) 23 S MSCH=$E(@ALPMSG@(MSH),6,6) 24 S MSCTR=$E(@ALPMSG@(MSH),4,8) 25 ;The message is confirmed to be a Pharmacy message 26 I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message" 27 ;A PID and PV1 segment is required for this message 28 S PID=0 29 F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID" 30 I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message" 31 ;Also the patient must have an inpatient status 32 S PV1=0 33 F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1" 34 I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message" 35 I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message" 36 S ORC=0 37 F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC" 38 I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message" 39 ;RE-BUILDING THE MESSAGE FOR BCBU 40 S ALPDFN=$P(@ALPMSG@(PID),MSFS,4) 41 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" 42 S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1) 43 I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC" 44 K ALPB 45 D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB) 46 SEED ;Entry point for ^ALPBIND 47 D INIT 48 S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D 49 . ;convert and move the message to the HLA array for transport 50 . S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB)) 51 . ;Now check for continuations 52 . S SUB1=0 53 . F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D 54 . . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1)) 55 . I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB 56 . I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB 57 . I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB 58 K HLA("HLS",MSH) 59 I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message" 60 S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1) 61 I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID" 62 S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 63 ;Fix RXE segement for Administration Type 64 D RXE 65 ;Get the Division that the patient is associated with 66 D PDIV 67 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" 68 I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV 69 ;SET NEW PV1 70 D NOW^%DTC 71 S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18") 72 S HLA("HLS",PV1)=STRING 73 I +ORC>0 D 74 . S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6)) 75 . Q:ALPST="" 76 . S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST 77 D AL1 78 ;Capture message to review for testing before sending 79 D SEND 80 EXIT ;EXIT and kill 81 K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR 82 K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN 83 K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST 84 K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL 85 Q ALPRSLT 86 INI() ;INTIAL SET UP ENTRY 87 G SEED 88 INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES 89 ;SET UP ENVIRONMENT FOR MESSAGE 90 K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS 91 S EVENT="PSB BCBU ORM SEND" 92 D INIT^HLFNC2(EVENT,.HL,1) 93 S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH") 94 Q 95 SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE 96 K ALPRSLT,ALPOPTS 97 D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS) 98 Q 99 AL1 ;ALLERGY SEGMENT BUILD 100 ;The will build the ALP segment with the curent allergies 101 ;for the patient to be added to the message 102 N DFN 103 Q:+ALPDFN'>0 104 K GMRAL 105 S DFN=ALPDFN 106 S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN 107 D EN1^GMRADPT 108 Q:'$D(GMRAL) 109 S ALPI=0,ALPC=1,ALPSYM="" 110 F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D 111 . S ALPADR="" 112 . I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** " 113 . S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7) 114 . S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8" 115 . ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D 116 . ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS 117 . ;S $P(ALPDATA,HLFS,6)=ALPSYM 118 . S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA 119 . S ALPC=ALPC+1 120 K GMRAL 121 Q 122 RXE ; 123 Q:+$G(RXE)'>0 124 K ^TMP("PSJ1",$J) 125 Q:'$D(HLA("HLS",RXE)) 126 S DATA=HLA("HLS",RXE) 127 D EN^PSJBCMA1(ALPDFN,ALPORD,1) 128 S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2) 129 Q:TYP="CONTINUOUS" 130 Q:TYP="FILL ON REQUEST" 131 S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2) 132 I ALP1[TYP Q 133 I ALP2[TYP Q 134 S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP 135 S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1 136 S HLA("HLS",RXE)=DATA 137 K TYP,ALP1,ALP2,^TMP("PSJ1",$J) 138 Q 139 PDIV ;PATIENT DIVISION 140 ;Check ALPBMDT Variable 141 S:+$G(ALPBMDT)'>0 ALPBMDT=0 142 S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT) 143 ;Screen Dom 144 Q:ALPDIV="DOM" 145 ;Now do I send the Message or not Based of Division 146 I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS") 147 I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV) 148 Q 149 MEDL(ALPML) ;Use this entry to send MedLog messages 150 N VAIN 151 ;ALPML is the IEN of the MedLog for file #53.79 152 I '$D(ALPML) Q "0^ALPML^No Med-Log Number" 153 I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid" 154 ;First get the required HL7 Variables 155 D INIT 156 ;Need to build the PID, PV1 and ORC segments 157 S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1) 158 I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log" 159 ;Get the Division that the patient is associated with 160 D PDIV 161 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" 162 I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log" 163 S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9) 164 S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7) 165 S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6) 166 S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1) 167 S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1) 168 S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non") 169 I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log" 170 S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 171 I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log" 172 S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 173 I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log" 174 S HLA("HLS",1)=PID 175 S HLA("HLS",2)=PV1 176 ;BUILD ORC SEGMENT 177 S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS 178 S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS 179 S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN 180 S HLA("HLS",3)=ORC 181 ;The Message is ready to send 182 D SEND 183 Q ALPRSLT 184 ; 185 ADMQ ;Need to que a single patient init for admissions 186 S ALDFN=ALPDFN 187 S ZTDTH=$$NOW^XLFDT 188 S ZTRTN="PAT^ALPBIND" 189 S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation" 190 S ZTIO="",ZTSAVE("ALDFN")="" 191 D ^%ZTLOAD 192 K ZTIO,ZTDESC,ZTRTN,ZTSK 193 Q 194 PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement 195 N VAIN 196 I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID" 197 D INIT 198 ;Check Movement type. If not a discharge then don't pass date and time 199 S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0 200 ;Get the Division that the patient is associated with 201 D PDIV 202 I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY" 203 I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move" 204 S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 205 S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 206 S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP) 207 D SEND 208 I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH 209 I $G(ALPTT)="ADMISSION" D ADMQ 210 ;SEND A DISCHARGE TO DIV SENDING ASIH 211 I $G(ALPTYP)[13!($G(ALPTYP)[40) D 212 .D INIT 213 .S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD 214 .I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD 215 .S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11) 216 .D GET^ALPBPARM(.HLL,ALPBDIV) 217 .S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19") 218 .S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18") 219 .S $P(HLA("HLS",2),HLFS,37)="ASIH" 220 .D SEND 221 Q ALPRSLT
Note:
See TracChangeset
for help on using the changeset viewer.
