ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 ;Jan 10, 2024@11:10
;;3.0;BAR CODE MED ADMIN;**8,102,105,110,146**;Mar 2004;Build 2
;
; Reference to ^DPT(DFN.,1) in ICR #10035
; Reference to EN^PSJBCBU in ICR #3876
;
;This is the main routine for the BCBU software.
;It handles all the entries points for the BCBU software.
;It also handles error checking.
IPH(ALPMSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
N ALPRSLT,HL,HLA,HLECH,HLQ
Q:'$D(ALPMSG)
;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
S ALPRSLT=$$IPH^ALPBINP(.ALPMSG)
;I $P(ALPRSLT,U,2)'="" D ERRLG
Q
MEDL(ALPML) ;Use this entry to send MedLog messages
N ALPRSLT
;ALPML is the IEN of the MedLog for file #53.79
Q:'$D(ALPML)
;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
S ALPRSLT=$$MEDL^ALPBINP(ALPML)
I $P(ALPRSLT,U,2)'="" D ERRLG
Q
NURV(ALDFN,ALPORD) ;Use this entry to send verifying nursing.
N ALPRSLT
;ALDFN is the IEN of the patient
;ALPORDR is the order number
Q:'$D(ALDFN)
Q:'$D(ALPORD)
;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
K ALPB
D EN^PSJBCBU(ALDFN,ALPORD,.ALPB)
S ALPBI=0
F S ALPBI=$O(ALPB(ALPBI)) Q:ALPBI'>0 D
. I $E(ALPB(ALPBI),1,3)="MSH" S MSH=ALPBI
. I $E(ALPB(ALPBI),1,3)="PID" S PID=ALPBI
. I $E(ALPB(ALPBI),1,3)="PV1" S PV1=ALPBI
. I $E(ALPB(ALPBI),1,3)="ORC" S ORC=ALPBI
I +$G(MSH)'>0 Q ;MISSING MSH SEGMENT BAD MESSAGE
S MSCTR=$E(ALPB(MSH),4,8)
S ALPRSLT=$$INI^ALPBINP()
K ALPB,ALPBI
Q
PMOV ;Entry Point to send patient movement
N ALPRSLT
;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
Q:+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
Q:'$D(DFN)!'$D(DGPMTYP)!'$D(DGPMUC)
;Screen out Lodgers
Q:DGPMUC["LODGER"
; PSB*3.0*146: Added line below
I DGPMUC="DISCHARGE",$G(^DPT(DFN,.1))]"" Q
S ALPRSLT=$$PMOV^ALPBINP(DFN,DGPMTYP,DGPMUC,$P($G(DGPMA),U))
I $P(ALPRSLT,U,2)'="" D ERRLG
Q
ERRLG ;Error Log Message
; Retrieving the Patient's division name to include on the alert
N ALPDFN,ALPDIV,ALPDIVST,ALPINST
S ALPDIVST=""
S ALPDFN=+$P($G(^PSB(53.79,+$G(ALPML),0)),U,1)
;If Patient Movement (not discharge), checking if the patient is still admitted, if not, QUIT
I $D(DGPMTYP),'$G(PSJDCA) D INP^VADPT I '$P($G(VAIN(4)),"^") Q
; If Patient is deceased don't generate alert
I $$DECEASED(ALPDFN) Q
I ALPDFN>0 D
. S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,0)
. I 'ALPDIV,$G(ALPML) S ALPDIV=$$CDIV^ALPBINP(ALPML)
. S ALPDIVST=$$GET1^DIQ(40.8,ALPDIV,1)
I ALPDIVST="" S ALPINST=+$$GET1^DIQ(53.79,+$G(ALPML),.03,"I"),ALPDIVST=$$GET1^DIQ(4,ALPINST,99)
;Alert
K XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
S XQA("G.PSB BCBU ERRORS")=""
S XQAMSG="BCBU Contingency Error"_$S(ALPDIVST:" / Site: "_ALPDIVST,1:"")_$S(ALPDFN:" / DFN: "_ALPDFN,1:"")
S XQADATA=ALPRSLT
S XQAROU="PERR^ALPBCBU"
D SETUP^XQALERT
Q
PERR ;Process the error
W @IOF,!,"PSB BCBU Contingency Error",!
W ?10,$P(XQADATA,U,2)_" / "_$P(XQADATA,U,3)
Q
;
DECEASED(DFN) ; Patient Deceased?
; Return: 1 (YES) or 0 (NO)
N VADM
D DEM^VADPT
Q $S('$G(VADM(6)):0,1:1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBCBU 3268 printed Nov 22, 2024@16:49:28 Page 2
ALPBCBU ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 ;Jan 10, 2024@11:10
+1 ;;3.0;BAR CODE MED ADMIN;**8,102,105,110,146**;Mar 2004;Build 2
+2 ;
+3 ; Reference to ^DPT(DFN.,1) in ICR #10035
+4 ; Reference to EN^PSJBCBU in ICR #3876
+5 ;
+6 ;This is the main routine for the BCBU software.
+7 ;It handles all the entries points for the BCBU software.
+8 ;It also handles error checking.
IPH(ALPMSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
+1 NEW ALPRSLT,HL,HLA,HLECH,HLQ
+2 if '$DATA(ALPMSG)
QUIT
+3 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
+4 if +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
QUIT
+5 SET ALPRSLT=$$IPH^ALPBINP(.ALPMSG)
+6 ;I $P(ALPRSLT,U,2)'="" D ERRLG
+7 QUIT
MEDL(ALPML) ;Use this entry to send MedLog messages
+1 NEW ALPRSLT
+2 ;ALPML is the IEN of the MedLog for file #53.79
+3 if '$DATA(ALPML)
QUIT
+4 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
+5 if +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
QUIT
+6 SET ALPRSLT=$$MEDL^ALPBINP(ALPML)
+7 IF $PIECE(ALPRSLT,U,2)'=""
DO ERRLG
+8 QUIT
NURV(ALDFN,ALPORD) ;Use this entry to send verifying nursing.
+1 NEW ALPRSLT
+2 ;ALDFN is the IEN of the patient
+3 ;ALPORDR is the order number
+4 if '$DATA(ALDFN)
QUIT
+5 if '$DATA(ALPORD)
QUIT
+6 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
+7 if +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
QUIT
+8 KILL ALPB
+9 DO EN^PSJBCBU(ALDFN,ALPORD,.ALPB)
+10 SET ALPBI=0
+11 FOR
SET ALPBI=$ORDER(ALPB(ALPBI))
if ALPBI'>0
QUIT
Begin DoDot:1
+12 IF $EXTRACT(ALPB(ALPBI),1,3)="MSH"
SET MSH=ALPBI
+13 IF $EXTRACT(ALPB(ALPBI),1,3)="PID"
SET PID=ALPBI
+14 IF $EXTRACT(ALPB(ALPBI),1,3)="PV1"
SET PV1=ALPBI
+15 IF $EXTRACT(ALPB(ALPBI),1,3)="ORC"
SET ORC=ALPBI
End DoDot:1
+16 ;MISSING MSH SEGMENT BAD MESSAGE
IF +$GET(MSH)'>0
QUIT
+17 SET MSCTR=$EXTRACT(ALPB(MSH),4,8)
+18 SET ALPRSLT=$$INI^ALPBINP()
+19 KILL ALPB,ALPBI
+20 QUIT
PMOV ;Entry Point to send patient movement
+1 NEW ALPRSLT
+2 ;CHECK IF BCBU IS ACTIVE AT PACKAGE LEVEL
+3 if +$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP ONLINE",1,"Q")'>0
QUIT
+4 if '$DATA(DFN)!'$DATA(DGPMTYP)!'$DATA(DGPMUC)
QUIT
+5 ;Screen out Lodgers
+6 if DGPMUC["LODGER"
QUIT
+7 ; PSB*3.0*146: Added line below
+8 IF DGPMUC="DISCHARGE"
IF $GET(^DPT(DFN,.1))]""
QUIT
+9 SET ALPRSLT=$$PMOV^ALPBINP(DFN,DGPMTYP,DGPMUC,$PIECE($GET(DGPMA),U))
+10 IF $PIECE(ALPRSLT,U,2)'=""
DO ERRLG
+11 QUIT
ERRLG ;Error Log Message
+1 ; Retrieving the Patient's division name to include on the alert
+2 NEW ALPDFN,ALPDIV,ALPDIVST,ALPINST
+3 SET ALPDIVST=""
+4 SET ALPDFN=+$PIECE($GET(^PSB(53.79,+$GET(ALPML),0)),U,1)
+5 ;If Patient Movement (not discharge), checking if the patient is still admitted, if not, QUIT
+6 IF $DATA(DGPMTYP)
IF '$GET(PSJDCA)
DO INP^VADPT
IF '$PIECE($GET(VAIN(4)),"^")
QUIT
+7 ; If Patient is deceased don't generate alert
+8 IF $$DECEASED(ALPDFN)
QUIT
+9 IF ALPDFN>0
Begin DoDot:1
+10 SET ALPDIV=$$DIV^ALPBUTL1(ALPDFN,0)
+11 IF 'ALPDIV
IF $GET(ALPML)
SET ALPDIV=$$CDIV^ALPBINP(ALPML)
+12 SET ALPDIVST=$$GET1^DIQ(40.8,ALPDIV,1)
End DoDot:1
+13 IF ALPDIVST=""
SET ALPINST=+$$GET1^DIQ(53.79,+$GET(ALPML),.03,"I")
SET ALPDIVST=$$GET1^DIQ(4,ALPINST,99)
+14 ;Alert
+15 KILL XQA,XQAMSG,XQAOPT,XQAROU,XQAID,XQADATA,XQAFLAG
+16 SET XQA("G.PSB BCBU ERRORS")=""
+17 SET XQAMSG="BCBU Contingency Error"_$SELECT(ALPDIVST:" / Site: "_ALPDIVST,1:"")_$SELECT(ALPDFN:" / DFN: "_ALPDFN,1:"")
+18 SET XQADATA=ALPRSLT
+19 SET XQAROU="PERR^ALPBCBU"
+20 DO SETUP^XQALERT
+21 QUIT
PERR ;Process the error
+1 WRITE @IOF,!,"PSB BCBU Contingency Error",!
+2 WRITE ?10,$PIECE(XQADATA,U,2)_" / "_$PIECE(XQADATA,U,3)
+3 QUIT
+4 ;
DECEASED(DFN) ; Patient Deceased?
+1 ; Return: 1 (YES) or 0 (NO)
+2 NEW VADM
+3 DO DEM^VADPT
+4 QUIT $SELECT('$GET(VADM(6)):0,1:1)
