ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;07/06/16 7:06am
;;3.0;BAR CODE MED ADMIN;**8,37,73,87,102,105,115**;May 2007;Build 3
;;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
;
;*87 - add ability to send two HL7 msgs for a Remove/Give scenario.
; Sends the associated Give first then the Remove Medlog trans.
;
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 (Ward)
D PDIV
;Override Ward Division with Clinic Division if present *87
N ALPCLDIV
D:$G(ALPORD)
. S ALPCLDIV=$$CDIVOR(ALPDFN,ALPORD) ;If Clin Ord, then returns DIV
. S:$G(ALPCLDIV) ALPDIV=ALPCLDIV
Q:(+$G(ALPDIV2)>0)&(ALPDIV'=$G(ALPDIV2)) "0^" ;no error
;
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,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
; If called from Workstation Init options it will screen out HL Links not selected
I $D(ALPHLINI) D I '$D(HLL("LINKS")) Q
. F I=1:1 Q:'$D(HLL("LINKS",I)) I '$D(ALPHLINI(HLL("LINKS",I))) K HLL("LINKS",I)
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 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 (Ward)
D PDIV
I ALPDIV="",$G(ALPML) S ALPDIV=$$CDIV(ALPML)
;Override Ward Division with Clinic Division if present *87
N ALPCLDIV
D:$G(ALPML)
. S ALPCLDIV=$$CDIV(ALPML) ;If Clinic, then will return a DIV
. S:$G(ALPCLDIV) ALPDIV=ALPCLDIV
;Quit if a specific Div was selected & Not = user selection *87
Q:(+$G(ALPDIV2)>0)&(ALPDIV'=$G(ALPDIV2)) "0^" ;no error
;
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 *87
; If this Medlog entry is Removed, then save HLA array and find the
; associated Give and alter the ORC seg in the HLA array and send the
; Removed 2nd.
I $P(HLA("HLS",3),HLFS,6)["REMOVED" D
. N SAVHLA,SAVHLL
. M SAVHLA=HLA,SAVHLL=HLL
. N GIVSTR,GIVDT,GIVBY,GIVBY,GIVBYN
. S GIVSTR=$$FINDGIVE(ALPML)
. S GIVDT=$P(GIVSTR,U,1),GIVBY=$P(GIVSTR,U,5)
. S $P(HLA("HLS",3),HLFS,6)="G"_HLCS_"GIVEN"
. S $P(HLA("HLS",3),HLFS,10)=$$HLDATE^HLFNC(GIVDT,"TS")
. S GIVBYN=$$GET1^DIQ(200,GIVBY,"NAME")
. S $P(HLA("HLS",3),HLFS,11)=GIVBY_HLCS_GIVBYN
. D SEND ;send assoc Medlog Give per a Removed trans
. D INIT
. M HLA=SAVHLA,HLL=SAVHLL
;
D SEND ;send current Medlog trans
Q ALPRSLT
;
ADMQ ;Need to que a single patient init for admissions
S ALDFN=ALPDFN
S ZTDTH=$$NOW^XLFDT
S ZTRTN="PAT^ALPBIND("""")" ;pass null Div par *87
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 / DFN: "_ALPDFN
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
Q ALPRSLT
;
CDIV(ML) ; Return DIVISION associated with input CLINIC
Q:'$G(ML) ""
N MLDATA,CLINICE,CLINICI,DIVE,DIVI,MLINST
S MLDATA=$G(^PSB(53.79,+ML,0))
S CLINICE=$P(MLDATA,"^",2),CLINICI=$O(^SC("B",CLINICE,0))
I CLINICI D
. S DIVI=$P($G(^SC(CLINICI,0)),"^",15)
E D
. S MLINST=+$P(MLDATA,"^",3),DIVI=+$O(^DG(40.8,"AD",MLINST,0))
; Retrieving HL7 parameters for the Clinic Division
S DIVE=$$GET1^DIQ(40.8,+DIVI,.01) D GET^ALPBPARM(.HLL,DIVE)
Q DIVI
;
CDIVOR(DFN,ORDER) ; Return DIVISION associated with input ORDER
Q:'$G(ORDER) "" Q:'$G(DFN) ""
N CLINICI,DIVI,DIVE
S CLINICI=$S(ORDER["P":+$G(^PS(53.1,+ORDER,"DSS")),ORDER["U":+$G(^PS(55,DFN,5,+ORDER,8)),ORDER["V":+$G(^PS(55,DFN,"IV",+ORDER,"DSS")),1:"")
I 'CLINICI Q "" I '$D(^SC(CLINICI,0)) Q ""
S DIVI=$P($G(^SC(CLINICI,0)),"^",15),DIVE=$P($G(^DG(40.8,+DIVI,0)),"^")
D GET^ALPBPARM(.HLL,DIVE)
Q $P(^SC(CLINICI,0),"^",15)
;
FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log *87
; When a Remove action occurs and saved to 53.79, the Give Action
; Status & Action Date/Time are overwritten. This Function will
; retrieve that Give info.
;
; Function returns - string formatted as the MAH report uses
; date/time ^ by initials ^ action code ^ ien of 53.79 file ^ by DUZ
;
N DA,STR
S STR=""
F DA=99999:0 S DA=$O(^PSB(53.79,IEN,.9,DA),-1) Q:'DA D Q:$P(STR,U,4)
.D:^PSB(53.79,IEN,.9,DA,0)["ACTION STATUS Set to 'GIVEN'"
..S $P(STR,U,1)=$P(^PSB(53.79,IEN,.9,DA,0),U)
..S $P(STR,U,2)=$P(^PSB(53.79,IEN,.9,DA,0),"'",4)
..S $P(STR,U,3)="G"
..S $P(STR,U,4)=IEN
..S $P(STR,U,5)=$P(^PSB(53.79,IEN,.9,DA,0),U,5)
Q STR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBINP 11973 printed Apr 09, 2024@20:45:45 Page 2
ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;07/06/16 7:06am
+1 ;;3.0;BAR CODE MED ADMIN;**8,37,73,87,102,105,115**;May 2007;Build 3
+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 ;
+14 ;*87 - add ability to send two HL7 msgs for a Remove/Give scenario.
+15 ; Sends the associated Give first then the Remove Medlog trans.
+16 ;
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 (Ward)
+21 DO PDIV
+22 ;Override Ward Division with Clinic Division if present *87
+23 NEW ALPCLDIV
+24 if $GET(ALPORD)
Begin DoDot:1
+25 ;If Clin Ord, then returns DIV
SET ALPCLDIV=$$CDIVOR(ALPDFN,ALPORD)
+26 if $GET(ALPCLDIV)
SET ALPDIV=ALPCLDIV
End DoDot:1
+27 ;no error
if (+$GET(ALPDIV2)>0)&(ALPDIV'=$GET(ALPDIV2))
QUIT "0^"
+28 ;
+29 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT "0^^Screen of DOMICILIARY"
+30 IF '$DATA(HLL("LINKS"))
QUIT "0^HL7^Missing HLL Links Array Division # "_ALPDIV
+31 ;SET NEW PV1
+32 DO NOW^%DTC
+33 SET STRING=$$EN^VAFHAPV1(ALPDFN,%,"2,3,7,18")
+34 SET HLA("HLS",PV1)=STRING
+35 IF +ORC>0
Begin DoDot:1
+36 SET ALPST=$$STAT^ALPBUTL1($PIECE(HLA("HLS",ORC),HLFS,6))
+37 if ALPST=""
QUIT
+38 SET $PIECE(HLA("HLS",ORC),HLFS,6)=$PIECE(HLA("HLS",ORC),HLFS,6)_HLCS_ALPST
End DoDot:1
+39 DO AL1
+40 ;Capture message to review for testing before sending
+41 DO SEND
EXIT ;EXIT and kill
+1 KILL HLA,SUB,SUB1,STRING,ALPLOC,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 ; If called from Workstation Init options it will screen out HL Links not selected
+3 IF $DATA(ALPHLINI)
Begin DoDot:1
+4 FOR I=1:1
if '$DATA(HLL("LINKS",I))
QUIT
IF '$DATA(ALPHLINI(HLL("LINKS",I)))
KILL HLL("LINKS",I)
End DoDot:1
IF '$DATA(HLL("LINKS"))
QUIT
+5 DO GENERATE^HLMA(EVENT,"LM",1,.ALPRSLT,"",.ALPOPTS)
+6 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 SET HLA("HLS",$ORDER(HLA("HLS",9999999),-1)+1)=ALPDATA
+17 SET ALPC=ALPC+1
End DoDot:1
+18 KILL GMRAL
+19 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 (Ward)
+11 DO PDIV
+12 IF ALPDIV=""
IF $GET(ALPML)
SET ALPDIV=$$CDIV(ALPML)
+13 ;Override Ward Division with Clinic Division if present *87
+14 NEW ALPCLDIV
+15 if $GET(ALPML)
Begin DoDot:1
+16 ;If Clinic, then will return a DIV
SET ALPCLDIV=$$CDIV(ALPML)
+17 if $GET(ALPCLDIV)
SET ALPDIV=ALPCLDIV
End DoDot:1
+18 ;Quit if a specific Div was selected & Not = user selection *87
+19 ;no error
if (+$GET(ALPDIV2)>0)&(ALPDIV'=$GET(ALPDIV2))
QUIT "0^"
+20 ;
+21 IF ALPDIV="DOM"
IF +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0
QUIT "0^^Screen of DOMICILIARY"
+22 IF '$DATA(HLL("LINKS"))
QUIT "0^"_ALPML_"^Missing HLL Links Array Med-Log"
+23 SET ALPST=$PIECE($GET(^PSB(53.79,ALPML,0)),U,9)
+24 SET ALPBY=$PIECE($GET(^PSB(53.79,ALPML,0)),U,7)
+25 SET ALPDT=$PIECE($GET(^PSB(53.79,ALPML,0)),U,6)
+26 SET ALPOR=$PIECE($GET(^PSB(53.79,ALPML,.1)),U,1)
+27 SET ALPBYN=$PIECE($GET(^VA(200,ALPBY,0)),U,1)
+28 SET ALPSTN=$SELECT($DATA(ALPST):$$EXTERNAL^DILFD(53.79,".09",,ALPST),1:"Non")
+29 IF '$DATA(ALPOR)
QUIT "0^"_ALPML_"^Invalid or Missing Pharmacy Order Number Med-Log"
+30 SET PID=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
+31 IF '$DATA(PID)
QUIT "0^"_ALPML_"^Invalid or Missing Patient - PID Med-Log"
+32 SET PV1=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")
+33 IF '$DATA(PV1)
QUIT "0^"_ALPML_"^Invalid or Missing Patient Location - PV1 Med-Log"
+34 SET HLA("HLS",1)=PID
+35 SET HLA("HLS",2)=PV1
+36 ;BUILD ORC SEGMENT
+37 SET ORC="ORC"_HLFS_"ML"_HLFS_ALPML_HLCS_"ML"_HLFS_ALPOR_HLCS_"PS"_HLFS
+38 SET ORC=ORC_HLFS_ALPST_HLCS_ALPSTN_HLFS_HLFS_HLFS_HLFS
+39 SET ORC=ORC_$$HLDATE^HLFNC(ALPDT,"TS")_HLFS_ALPBY_HLCS_ALPBYN
+40 SET HLA("HLS",3)=ORC
+41 ;The Message is ready to send *87
+42 ; If this Medlog entry is Removed, then save HLA array and find the
+43 ; associated Give and alter the ORC seg in the HLA array and send the
+44 ; Removed 2nd.
+45 IF $PIECE(HLA("HLS",3),HLFS,6)["REMOVED"
Begin DoDot:1
+46 NEW SAVHLA,SAVHLL
+47 MERGE SAVHLA=HLA,SAVHLL=HLL
+48 NEW GIVSTR,GIVDT,GIVBY,GIVBY,GIVBYN
+49 SET GIVSTR=$$FINDGIVE(ALPML)
+50 SET GIVDT=$PIECE(GIVSTR,U,1)
SET GIVBY=$PIECE(GIVSTR,U,5)
+51 SET $PIECE(HLA("HLS",3),HLFS,6)="G"_HLCS_"GIVEN"
+52 SET $PIECE(HLA("HLS",3),HLFS,10)=$$HLDATE^HLFNC(GIVDT,"TS")
+53 SET GIVBYN=$$GET1^DIQ(200,GIVBY,"NAME")
+54 SET $PIECE(HLA("HLS",3),HLFS,11)=GIVBY_HLCS_GIVBYN
+55 ;send assoc Medlog Give per a Removed trans
DO SEND
+56 DO INIT
+57 MERGE HLA=SAVHLA,HLL=SAVHLL
End DoDot:1
+58 ;
+59 ;send current Medlog trans
DO SEND
+60 QUIT ALPRSLT
+61 ;
ADMQ ;Need to que a single patient init for admissions
+1 SET ALDFN=ALPDFN
+2 SET ZTDTH=$$NOW^XLFDT
+3 ;pass null Div par *87
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 / DFN: "_ALPDFN
+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
+27 QUIT ALPRSLT
+28 ;
CDIV(ML) ; Return DIVISION associated with input CLINIC
+1 if '$GET(ML)
QUIT ""
+2 NEW MLDATA,CLINICE,CLINICI,DIVE,DIVI,MLINST
+3 SET MLDATA=$GET(^PSB(53.79,+ML,0))
+4 SET CLINICE=$PIECE(MLDATA,"^",2)
SET CLINICI=$ORDER(^SC("B",CLINICE,0))
+5 IF CLINICI
Begin DoDot:1
+6 SET DIVI=$PIECE($GET(^SC(CLINICI,0)),"^",15)
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET MLINST=+$PIECE(MLDATA,"^",3)
SET DIVI=+$ORDER(^DG(40.8,"AD",MLINST,0))
End DoDot:1
+9 ; Retrieving HL7 parameters for the Clinic Division
+10 SET DIVE=$$GET1^DIQ(40.8,+DIVI,.01)
DO GET^ALPBPARM(.HLL,DIVE)
+11 QUIT DIVI
+12 ;
CDIVOR(DFN,ORDER) ; Return DIVISION associated with input ORDER
+1 if '$GET(ORDER)
QUIT ""
if '$GET(DFN)
QUIT ""
+2 NEW CLINICI,DIVI,DIVE
+3 SET CLINICI=$SELECT(ORDER["P":+$GET(^PS(53.1,+ORDER,"DSS")),ORDER["U":+$GET(^PS(55,DFN,5,+ORDER,8)),ORDER["V":+$GET(^PS(55,DFN,"IV",+ORDER,"DSS")),1:"")
+4 IF 'CLINICI
QUIT ""
IF '$DATA(^SC(CLINICI,0))
QUIT ""
+5 SET DIVI=$PIECE($GET(^SC(CLINICI,0)),"^",15)
SET DIVE=$PIECE($GET(^DG(40.8,+DIVI,0)),"^")
+6 DO GET^ALPBPARM(.HLL,DIVE)
+7 QUIT $PIECE(^SC(CLINICI,0),"^",15)
+8 ;
FINDGIVE(IEN) ;Finds the last Give date/time in the Audit log *87
+1 ; When a Remove action occurs and saved to 53.79, the Give Action
+2 ; Status & Action Date/Time are overwritten. This Function will
+3 ; retrieve that Give info.
+4 ;
+5 ; Function returns - string formatted as the MAH report uses
+6 ; date/time ^ by initials ^ action code ^ ien of 53.79 file ^ by DUZ
+7 ;
+8 NEW DA,STR
+9 SET STR=""
+10 FOR DA=99999:0
SET DA=$ORDER(^PSB(53.79,IEN,.9,DA),-1)
if 'DA
QUIT
Begin DoDot:1
+11 if ^PSB(53.79,IEN,.9,DA,0)["ACTION STATUS Set to 'GIVEN'"
Begin DoDot:2
+12 SET $PIECE(STR,U,1)=$PIECE(^PSB(53.79,IEN,.9,DA,0),U)
+13 SET $PIECE(STR,U,2)=$PIECE(^PSB(53.79,IEN,.9,DA,0),"'",4)
+14 SET $PIECE(STR,U,3)="G"
+15 SET $PIECE(STR,U,4)=IEN
+16 SET $PIECE(STR,U,5)=$PIECE(^PSB(53.79,IEN,.9,DA,0),U,5)
End DoDot:2
End DoDot:1
if $PIECE(STR,U,4)
QUIT
+17 QUIT STR
