ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
;;3.0;BAR CODE MED ADMIN;**8,37,1018**;May 2007;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;This routine will intercept the HL7 message that it sent from Pharmacy
;to CPRS to update order information. The message is then parsed and
;repackage so it can be sent to the BCBU workstation.
;
; Reference/IA
; EN^PSJBCBU/3876
; $$EN^VAFHLPID/263
; $$EN^VAFHAPV1/4512
; EN1^GMRADPT/10099
; EN^PSJBCMA1/2829
;
IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
N VAIN,ALPMSG
S ALPMSG=$S($L($G(MSG)):MSG,1:"MSG")
I '$O(@ALPMSG@(0)) Q "0^MSG^Missing Message Array"
S MSH=0
F S MSH=$O(@ALPMSG@(MSH)) Q:MSH'>0 Q:$E(@ALPMSG@(MSH),1,3)="MSH"
I +MSH'>0 Q "0^MSG^Missing MSH Segment Bad Message"
S MSFS=$E(@ALPMSG@(MSH),4,4)
S MSCS=$E(@ALPMSG@(MSH),5,5)
S MSCH=$E(@ALPMSG@(MSH),6,6)
S MSCTR=$E(@ALPMSG@(MSH),4,8)
;The message is confirmed to be a Pharmacy message
I $P(@ALPMSG@(MSH),MSFS,3)'="PHARMACY" Q "1^^Not a Pharmacy Message"
;A PID and PV1 segment is required for this message
S PID=0
F S PID=$O(@ALPMSG@(PID)) Q:PID'>0 Q:$E(@ALPMSG@(PID),1,3)="PID"
I +PID'>0 Q "0^MSG^Missing PID Segment Bad Message"
;Also the patient must have an inpatient status
S PV1=0
F S PV1=$O(@ALPMSG@(PV1)) Q:PV1'>0 Q:$E(@ALPMSG@(PV1),1,3)="PV1"
I +PV1'>0 Q "0^MSG^Missing PV1 Segment Bad Message"
I $P(@ALPMSG@(PV1),MSFS,3)'="I" Q "1^^Not an Inpatient Pharmacy Message"
S ORC=0
F S ORC=$O(@ALPMSG@(ORC)) Q:ORC'>0 Q:$E(@ALPMSG@(ORC),1,3)="ORC"
I +ORC'>0 Q "0^MSG^Missing ORC Segment Bad Message"
;RE-BUILDING THE MESSAGE FOR BCBU
S ALPDFN=$P(@ALPMSG@(PID),MSFS,4)
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
S ALPORD=$P($P(@ALPMSG@(ORC),MSFS,4),MSCS,1)
I ALPORD="" Q "0^MSG^Invalid or Missing Order Number - ORC"
K ALPB
D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
SEED ;Entry point for ^ALPBIND
N VAIN
D INIT
S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D
. ;convert and move the message to the HLA array for transport
. S HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
. ;Now check for continuations
. S SUB1=0
. F S SUB1=$O(ALPB(SUB,SUB1)) Q:'SUB1 D
. . S HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
. I $E(HLA("HLS",SUB),1,3)="RXE" S RXE=SUB
. I $E(HLA("HLS",SUB),1,3)="PID" S PID=SUB
. I $E(HLA("HLS",SUB),1,3)="PV1" S PV1=SUB
K HLA("HLS",MSH)
I '$D(HLA("HLS",PID)) Q "0^MSG^Missing PID Segment Bad Message"
S ALPDFN=$P($P(HLA("HLS",PID),HLFS,4),HLCS,1)
I +ALPDFN'>0 Q "0^MSG^Invalid or Missing Patient - PID"
S HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
;Fix RXE segement for Administration Type
D RXE
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
;SET NEW PV1
D NOW^%DTC
S STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
S HLA("HLS",PV1)=STRING
I +ORC>0 D
. S ALPST=$$STAT^ALPBUTL1($P(HLA("HLS",ORC),HLFS,6))
. Q:ALPST=""
. S $P(HLA("HLS",ORC),HLFS,6)=$P(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
D AL1
;Capture message to review for testing before sending
D SEND
EXIT ;EXIT and kill
K HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
K MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
K ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
K ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
Q ALPRSLT
INI() ;INTIAL SET UP ENTRY
G SEED
INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
;SET UP ENVIRONMENT FOR MESSAGE
K HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
S EVENT="PSB BCBU ORM SEND"
D INIT^HLFNC2(EVENT,.HL,1)
S HLCS=$E(HL("ECH")),HLCTR=HLFS_HL("ECH")
Q
SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
K ALPRSLT,ALPOPTS
D ^ALPBHL2 S ALPRSLT="FILED" ;Stuff LOCAL FILE VAOIT FOXK
;NO HL7 MESSAGE ONLY STUFF LOCAL
;D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
Q
AL1 ;ALLERGY SEGMENT BUILD
;The will build the ALP segment with the curent allergies
;for the patient to be added to the message
N DFN
Q:+ALPDFN'>0
K GMRAL
S DFN=ALPDFN
S GMRA="0^0^111" ;DEFINES WHAT ALLERGIES TO RETURN
D EN1^GMRADPT
Q:'$D(GMRAL)
S ALPI=0,ALPC=1,ALPSYM=""
F S ALPI=$O(GMRAL(ALPI)) Q:+ALPI'>0 D
. S ALPADR=""
. I $P($P(GMRAL(ALPI),U,8),";",2)="P" S ALPADR="**ADR** "
. S ALPDATA="AL1"_HLFS_ALPC_HLFS_$P(GMRAL(ALPI),U,7)
. S ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$E($P(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
. ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D
. ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
. ;S $P(ALPDATA,HLFS,6)=ALPSYM
. S HLA("HLS",$O(HLA("HLS",9999999),-1)+1)=ALPDATA
. S ALPC=ALPC+1
K GMRAL
Q
RXE ;
Q:+$G(RXE)'>0
K ^TMP("PSJ1",$J)
Q:'$D(HLA("HLS",RXE))
S DATA=HLA("HLS",RXE)
D EN^PSJBCMA1(ALPDFN,ALPORD,1)
S TYP=$P($G(^TMP("PSJ1",$J,4)),U,2)
Q:TYP="CONTINUOUS"
Q:TYP="FILL ON REQUEST"
S ALP1=$P(DATA,HLFS,2),ALP2=$P(ALP1,HLCS,2)
I ALP1[TYP Q
I ALP2[TYP Q
S $P(ALP2,"&",1)=$P(ALP2,"&",1)_" "_TYP
S $P(ALP1,HLCS,2)=ALP2,$P(DATA,HLFS,2)=ALP1
S HLA("HLS",RXE)=DATA
K TYP,ALP1,ALP2,^TMP("PSJ1",$J)
Q
PDIV ;PATIENT DIVISION
;Check ALPBMDT Variable
S:+$G(ALPBMDT)'>0 ALPBMDT=0
S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
;Screen Dom
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
;Now do I send the Message or not Based of Division
I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
Q
MEDL(ALPML) ;Use this entry to send MedLog messages
N VAIN
;ALPML is the IEN of the MedLog for file #53.79
I '$D(ALPML) Q "0^ALPML^No Med-Log Number"
I '$D(^PSB(53.79,ALPML,0)) Q "0^"_ALPML_"^Med - Log Number Invalid"
;First get the required HL7 Variables
D INIT
;Need to build the PID, PV1 and ORC segments
S ALPDFN=+$P($G(^PSB(53.79,ALPML,0)),U,1)
I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
S ALPDT=$P($G(^PSB(53.79,ALPML,0)),U,6)
S ALPOR=$P($G(^PSB(53.79,ALPML,.1)),U,1)
S ALPBYN=$P($G(^VA(200,ALPBY,0)),U,1)
S ALPSTN=$S($D(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
I '$D(ALPOR) Q "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
S PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
I '$D(PID) Q "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
S PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
I '$D(PV1) Q "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
S HLA("HLS",1)=PID
S HLA("HLS",2)=PV1
;BUILD ORC SEGMENT
S ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
S ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
S ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
S HLA("HLS",3)=ORC
;The Message is ready to send
D SEND
Q ALPRSLT
;
ADMQ ;Need to que a single patient init for admissions
S ALDFN=ALPDFN
S ZTDTH=$$NOW^XLFDT
S ZTRTN="PAT^ALPBIND"
S ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
S ZTIO="",ZTSAVE("ALDFN")=""
D ^%ZTLOAD
K ZTIO,ZTDESC,ZTRTN,ZTSK
Q
PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
N VAIN
I +$G(ALPDFN)'>0 Q "0^^Missing Patient ID"
D INIT
;Check Movement type. If not a discharge then don't pass date and time
S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
S:$G(ALPTT)="DISCHARGE" $P(HLA("HLS",2),HLFS,37)=$G(ALPTYP)
D SEND
I ALPTYP=14!(ALPTYP=41) S ALPTT="ADMISSION" ;FOR RETURN FROM ASIH
I $G(ALPTT)="ADMISSION" D ADMQ
;SEND A DISCHARGE TO DIV SENDING ASIH
I $G(ALPTYP)[13!($G(ALPTYP)[40) D
.D INIT
.S ALPWRD=$P($G(DGPMVI(5)),U,1) ;LAST WARD
.I +ALPWRD'>0 S ALPRSLT="0^^Screen - No Ward" Q ;NO WARD
.S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
.D GET^ALPBPARM(.HLL,ALPBDIV)
.S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
.S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
.S $P(HLA("HLS",2),HLFS,37)="ASIH"
.D SEND
ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
+1 ;;3.0;BAR CODE MED ADMIN;**8,37,1018**;May 2007;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+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 ;
IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
+1 NEW VAIN,ALPMSG
+2 SET ALPMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
+3 IF '$ORDER(@ALPMSG@(0))
QUIT "0^MSG^Missing Message Array"
+4 SET MSH=0
+5 FOR
SET MSH=$ORDER(@ALPMSG@(MSH))
IF MSH'>0
QUIT
IF $EXTRACT(@ALPMSG@(MSH),1,3)="MSH"
QUIT
+6 IF +MSH'>0
QUIT "0^MSG^Missing MSH Segment Bad Message"
+7 SET MSFS=$EXTRACT(@ALPMSG@(MSH),4,4)
+8 SET MSCS=$EXTRACT(@ALPMSG@(MSH),5,5)
+9 SET MSCH=$EXTRACT(@ALPMSG@(MSH),6,6)
+10 SET MSCTR=$EXTRACT(@ALPMSG@(MSH),4,8)
+11 ;The message is confirmed to be a Pharmacy message
+12 IF $PIECE(@ALPMSG@(MSH),MSFS,3)'="PHARMACY"
QUIT "1^^Not a Pharmacy Message"
+13 ;A PID and PV1 segment is required for this message
+14 SET PID=0
+15 FOR
SET PID=$ORDER(@ALPMSG@(PID))
IF PID'>0
QUIT
IF $EXTRACT(@ALPMSG@(PID),1,3)="PID"
QUIT
+16 IF +PID'>0
QUIT "0^MSG^Missing PID Segment Bad Message"
+17 ;Also the patient must have an inpatient status
+18 SET PV1=0
+19 FOR
SET PV1=$ORDER(@ALPMSG@(PV1))
IF PV1'>0
QUIT
IF $EXTRACT(@ALPMSG@(PV1),1,3)="PV1"
QUIT
+20 IF +PV1'>0
QUIT "0^MSG^Missing PV1 Segment Bad Message"
+21 IF $PIECE(@ALPMSG@(PV1),MSFS,3)'="I"
QUIT "1^^Not an Inpatient Pharmacy Message"
+22 SET ORC=0
+23 FOR
SET ORC=$ORDER(@ALPMSG@(ORC))
IF ORC'>0
QUIT
IF $EXTRACT(@ALPMSG@(ORC),1,3)="ORC"
QUIT
+24 IF +ORC'>0
QUIT "0^MSG^Missing ORC Segment Bad Message"
+25 ;RE-BUILDING THE MESSAGE FOR BCBU
+26 SET ALPDFN=$PIECE(@ALPMSG@(PID),MSFS,4)
+27 IF +ALPDFN'>0
QUIT "0^MSG^Invalid or Missing Patient - PID"
+28 SET ALPORD=$PIECE($PIECE(@ALPMSG@(ORC),MSFS,4),MSCS,1)
+29 IF ALPORD=""
QUIT "0^MSG^Invalid or Missing Order Number - ORC"
+30 KILL ALPB
+31 DO EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
SEED ;Entry point for ^ALPBIND
+1 NEW VAIN
+2 DO INIT
+3 SET SUB=0
FOR
SET SUB=$ORDER(ALPB(SUB))
IF 'SUB
QUIT
Begin DoDot:1
+4 ;convert and move the message to the HLA array for transport
+5 SET HLA("HLS",SUB)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB))
+6 ;Now check for continuations
+7 SET SUB1=0
+8 FOR
SET SUB1=$ORDER(ALPB(SUB,SUB1))
IF 'SUB1
QUIT
Begin DoDot:2
+9 SET HLA("HLS",SUB,SUB1)=$$CNV^ALPBUTL1(MSCTR,HLCTR,ALPB(SUB,SUB1))
End DoDot:2
+10 IF $EXTRACT(HLA("HLS",SUB),1,3)="RXE"
SET RXE=SUB
+11 IF $EXTRACT(HLA("HLS",SUB),1,3)="PID"
SET PID=SUB
+12 IF $EXTRACT(HLA("HLS",SUB),1,3)="PV1"
SET PV1=SUB
End DoDot:1
+13 KILL HLA("HLS",MSH)
+14 IF '$DATA(HLA("HLS",PID))
QUIT "0^MSG^Missing PID Segment Bad Message"
+15 SET ALPDFN=$PIECE($PIECE(HLA("HLS",PID),HLFS,4),HLCS,1)
+16 IF +ALPDFN'>0
QUIT "0^MSG^Invalid or Missing Patient - PID"
+17 SET HLA("HLS",PID)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+18 ;Fix RXE segement for Administration Type
+19 DO RXE
+20 ;Get the Division that the patient is associated with
+21 DO PDIV
+22 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT "0^^Screen of DOMICILIARY"
+23 IF '$DATA(HLL("LINKS"))
QUIT "0^HL7^Missing HLL Links Array Division # "_ALPDIV
+24 ;SET NEW PV1
+25 DO NOW^%DTC
+26 SET STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
+27 SET HLA("HLS",PV1)=STRING
+28 IF +ORC>0
Begin DoDot:1
+29 SET ALPST=$$STAT^ALPBUTL1($PIECE(HLA("HLS",ORC),HLFS,6))
+30 IF ALPST=""
QUIT
+31 SET $PIECE(HLA("HLS",ORC),HLFS,6)=$PIECE(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
End DoDot:1
+32 DO AL1
+33 ;Capture message to review for testing before sending
+34 DO SEND
EXIT ;EXIT and kill
+1 KILL HLA,SUB,SUB1,STRING,ALPLOC,HLCS,HLCTR,HLFS,MSCH,MSCS,MSCTR
+2 KILL MSH,ORC,PID,PV1,RXE,RXR,ALPB,ALPBY,ALPBYN,ALPC,ALPDATA,ALPDFN
+3 KILL ALPDT,ALPI,ALPII,ALPIV,ALPOPTS,ALPOR,ALPORD,ALPST
+4 KILL ALPSTN,ALPSYM,EVENT,GMRA,GMRAL
+5 QUIT ALPRSLT
INI() ;INTIAL SET UP ENTRY
+1 GOTO SEED
INIT ;CALL HL7 TO INITIALIZE MESSAGE VARIABLES
+1 ;SET UP ENVIRONMENT FOR MESSAGE
+2 KILL HL,HLA,HLECH,HLQ,ALPRSLT,ALPOPTS
+3 SET EVENT="PSB BCBU ORM SEND"
+4 DO INIT^HLFNC2(EVENT,.HL,1)
+5 SET HLCS=$EXTRACT(HL("ECH"))
SET HLCTR=HLFS_HL("ECH")
+6 QUIT
SEND ;CALL HL7 TO TRANSMIT SINGLE MESSAGE
+1 KILL ALPRSLT,ALPOPTS
+2 ;Stuff LOCAL FILE VAOIT FOXK
DO ^ALPBHL2
SET ALPRSLT="FILED"
+3 ;NO HL7 MESSAGE ONLY STUFF LOCAL
+4 ;D GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
+5 QUIT
AL1 ;ALLERGY SEGMENT BUILD
+1 ;The will build the ALP segment with the curent allergies
+2 ;for the patient to be added to the message
+3 NEW DFN
+4 IF +ALPDFN'>0
QUIT
+5 KILL GMRAL
+6 SET DFN=ALPDFN
+7 ;DEFINES WHAT ALLERGIES TO RETURN
SET GMRA="0^0^111"
+8 DO EN1^GMRADPT
+9 IF '$DATA(GMRAL)
QUIT
+10 SET ALPI=0
SET ALPC=1
SET ALPSYM=""
+11 FOR
SET ALPI=$ORDER(GMRAL(ALPI))
IF +ALPI'>0
QUIT
Begin DoDot:1
+12 SET ALPADR=""
+13 IF $PIECE($PIECE(GMRAL(ALPI),U,8),";",2)="P"
SET ALPADR="**ADR** "
+14 SET ALPDATA="AL1"_HLFS_ALPC_HLFS_$PIECE(GMRAL(ALPI),U,7)
+15 SET ALPDATA=ALPDATA_HLFS_ALPI_HLCS_ALPADR_$EXTRACT($PIECE(GMRAL(ALPI),U,2),1,25)_HLCS_"VA120.8"
+16 ;S ALPII=0 F S ALPII=$O(GMRAL(ALPI,"S",ALPII)) Q:+ALPII'>0 D
+17 ;. S ALPSYM=ALPSYM_$P(GMRAL(ALPI,"S",ALPII),";",1)_HLCS
+18 ;S $P(ALPDATA,HLFS,6)=ALPSYM
+19 SET HLA("HLS",$ORDER(HLA("HLS",9999999),-1)+1)=ALPDATA
+20 SET ALPC=ALPC+1
End DoDot:1
+21 KILL GMRAL
+22 QUIT
RXE ;
+1 IF +$GET(RXE)'>0
QUIT
+2 KILL ^TMP("PSJ1",$JOB)
+3 IF '$DATA(HLA("HLS",RXE))
QUIT
+4 SET DATA=HLA("HLS",RXE)
+5 DO EN^PSJBCMA1(ALPDFN,ALPORD,1)
+6 SET TYP=$PIECE($GET(^TMP("PSJ1",$JOB,4)),U,2)
+7 IF TYP="CONTINUOUS"
QUIT
+8 IF TYP="FILL ON REQUEST"
QUIT
+9 SET ALP1=$PIECE(DATA,HLFS,2)
SET ALP2=$PIECE(ALP1,HLCS,2)
+10 IF ALP1[TYP
QUIT
+11 IF ALP2[TYP
QUIT
+12 SET $PIECE(ALP2,"&",1)=$PIECE(ALP2,"&",1)_" "_TYP
+13 SET $PIECE(ALP1,HLCS,2)=ALP2
SET $PIECE(DATA,HLFS,2)=ALP1
+14 SET HLA("HLS",RXE)=DATA
+15 KILL TYP,ALP1,ALP2,^TMP("PSJ1",$JOB)
+16 QUIT
PDIV ;PATIENT DIVISION
+1 ;Check ALPBMDT Variable
+2 IF +$GET(ALPBMDT)'>0
SET ALPBMDT=0
+3 SET ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
+4 ;Screen Dom
+5 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT
+6 ;Now do I send the Message or not Based of Division
+7 IF $DATA(ALPHLL("LINKS"))
MERGE HLL("LINKS")=ALPHLL("LINKS")
+8 IF '$DATA(HLL("LINKS"))
DO GET^ALPBPARM(.HLL,ALPDIV)
+9 QUIT
MEDL(ALPML) ;Use this entry to send MedLog messages
+1 NEW VAIN
+2 ;ALPML is the IEN of the MedLog for file #53.79
+3 IF '$DATA(ALPML)
QUIT "0^ALPML^No Med-Log Number"
+4 IF '$DATA(^PSB(53.79,ALPML,0))
QUIT "0^"_ALPML_"^Med - Log Number Invalid"
+5 ;First get the required HL7 Variables
+6 DO INIT
+7 ;Need to build the PID, PV1 and ORC segments
+8 SET ALPDFN=+$PIECE($GET(^PSB(53.79,ALPML,0)),U,1)
+9 IF +ALPDFN'>0
QUIT "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
+10 ;Get the Division that the patient is associated with
+11 DO PDIV
+12 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT "0^^Screen of DOMICILIARY"
+13 IF '$DATA(HLL("LINKS"))
QUIT "0^"_ALPML_"^Missing HLL Links Array Med-Log"
+14 SET ALPST=$PIECE($GET(^PSB(53.79,ALPML,0)),U,9)
+15 SET ALPBY=$PIECE($GET(^PSB(53.79,ALPML,0)),U,7)
+16 SET ALPDT=$PIECE($GET(^PSB(53.79,ALPML,0)),U,6)
+17 SET ALPOR=$PIECE($GET(^PSB(53.79,ALPML,.1)),U,1)
+18 SET ALPBYN=$PIECE($GET(^VA(200,ALPBY,0)),U,1)
+19 SET ALPSTN=$SELECT($DATA(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
+20 IF '$DATA(ALPOR)
QUIT "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
+21 SET PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+22 IF '$DATA(PID)
QUIT "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
+23 SET PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+24 IF '$DATA(PV1)
QUIT "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
+25 SET HLA("HLS",1)=PID
+26 SET HLA("HLS",2)=PV1
+27 ;BUILD ORC SEGMENT
+28 SET ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
+29 SET ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
+30 SET ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
+31 SET HLA("HLS",3)=ORC
+32 ;The Message is ready to send
+33 DO SEND
+34 QUIT ALPRSLT
+35 ;
ADMQ ;Need to que a single patient init for admissions
+1 SET ALDFN=ALPDFN
+2 SET ZTDTH=$$NOW^XLFDT
+3 SET ZTRTN="PAT^ALPBIND"
+4 SET ZTDESC="PSB - Initialize Single Patient on Admission Contingency Workstation"
+5 SET ZTIO=""
SET ZTSAVE("ALDFN")=""
+6 DO ^%ZTLOAD
+7 KILL ZTIO,ZTDESC,ZTRTN,ZTSK
+8 QUIT
PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
+1 NEW VAIN
+2 IF +$GET(ALPDFN)'>0
QUIT "0^^Missing Patient ID"
+3 DO INIT
+4 ;Check Movement type. If not a discharge then don't pass date and time
+5 IF $GET(ALPTT)'="DISCHARGE"
SET ALPBMDT=0
+6 ;Get the Division that the patient is associated with
+7 DO PDIV
+8 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT "0^^Screen of DOMICILIARY"
+9 IF '$DATA(HLL("LINKS"))
QUIT "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
+10 SET HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+11 SET HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+12 IF $GET(ALPTT)="DISCHARGE"
SET $PIECE(HLA("HLS",2),HLFS,37)=$GET(ALPTYP)
+13 DO SEND
+14 ;FOR RETURN FROM ASIH
IF ALPTYP=14!(ALPTYP=41)
SET ALPTT="ADMISSION"
+15 IF $GET(ALPTT)="ADMISSION"
DO ADMQ
+16 ;SEND A DISCHARGE TO DIV SENDING ASIH
+17 IF $GET(ALPTYP)[13!($GET(ALPTYP)[40)
Begin DoDot:1
+18 DO INIT
+19 ;LAST WARD
SET ALPWRD=$PIECE($GET(DGPMVI(5)),U,1)
+20 ;NO WARD
IF +ALPWRD'>0
SET ALPRSLT="0^^Screen - No Ward"
QUIT
+21 SET ALPBDIV=$PIECE($GET(^DIC(42,ALPWRD,0)),U,11)
+22 DO GET^ALPBPARM(.HLL,ALPBDIV)
+23 SET HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+24 SET HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+25 SET $PIECE(HLA("HLS",2),HLFS,37)="ASIH"
+26 DO SEND
End DoDot:1
