PSJBCMA4 ;BIR/JLC - BCMA ORDER UPDATE FOR INPATIENT MEDS ;18 JUN 01
;;5.0;INPATIENT MEDICATIONS ;**63,66,58,104,328**;16 DEC 97;Build 6
;
;Reference to ^DPT is supported by DBIA 10035
;Reference to ^PS(55 is supported by DBIA 2191
;Reference to ^XMB is supported by DBIA 1131
;Reference to ^%DTC is supported by DBIA 10000
;Reference to ^DIE is supported by DBIA 10018
;Reference to ^DIQ is supported by DBIA 2056
;Reference to ^XMD is supported by DBIA 10070
;
ENE(DFN,ON) ;
N PSJIEN,PSJSTOP,PSJSTAT,PSJSTOP,PSJNOW,DA,DR,DIE,PSIVACT,ON55,PSIVREA,PSIVAL,PSIVALT,PSJSCH,X
I $G(DFN)=""!($G(ON)="") Q
D NOW^%DTC S PSJNOW=%
I ON["V" D Q
. I '$D(^PS(55,DFN,"IV",+ON)) Q
. S X=$G(^PS(55,DFN,"IV",+ON,0))
. S PSJSTART=$P(X,"^",2),PSJSTOP=$P(X,"^",3),PSJSCH=$P(X,"^",9),PSJSTAT=$P(X,"^",17)
. I $P($G(^PS(55,DFN,"IV",+ON,.2)),"^",4)="D" Q
. S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
. I PSJSTAT'="A" D IEA(0) Q
. I PSJSTOP'>PSJNOW D IEA(0) Q
. I $$ONE^PSJBCMA(DFN,ON,PSJSCH,PSJSTART,PSJSTOP)'="O" D IEA(0) Q
. S PSIVACT=1,DR="116////"_PSJSTOP_";.03////"_PSJNOW_";100////E;147////1" D ^DIE
. D IEA(1),EN1^PSJHL2(DFN,"SC",ON,"BCMA EXPIRED")
I ON["U" D Q
. I '$D(^PS(55,DFN,5,+ON)) Q
. S X=$G(^PS(55,DFN,5,+ON,2)),PSJSCH=$P(X,"^"),PSJSTART=$P(X,"^",2),PSJSTOP=$P(X,"^",4)
. S PSJIEN=+ON_","_DFN_",",PSJSTAT=$$GET1^DIQ(55.06,PSJIEN,28,"I")
. I $P($G(^PS(55,DFN,5,+ON,.2)),"^",4)="D" Q
. S DIE="^PS(55,"_DFN_",5,",DA=+ON,DA(1)=DFN
. I PSJSTAT'="A" D UEA(0) Q
. I PSJSTOP'>PSJNOW D UEA(0) Q
. I $$ONE^PSJBCMA(DFN,ON,PSJSCH,PSJSTART,PSJSTOP)'="O" D UEA(0) Q
. S DR="25////"_PSJSTOP_";34////"_PSJNOW_";28////E;123////1" D ^DIE
. D UEA(1),EN1^PSJHL2(DFN,"SC",ON,"BCMA EXPIRED")
Q
ENR(DFN,ON) ;
N PSJIEN,PSJORIG,PSJSTAT,PSJSTOP,PSJNOW,DA,DR,DIE,PSIVACT,PSJF,X,PSJ,XMY,XMDUZ,XMSUB,XMTEXT
I $G(DFN)=""!($G(ON)="") Q
D NOW^%DTC S PSJNOW=%
I ON["V" D Q
. I '$D(^PS(55,DFN,"IV",+ON)) Q
. I '$P($G(^PS(55,DFN,"IV",+ON,"DSS")),U,2) N VAIP D IN5^VADPT Q:'$G(VAIP(1))
. S PSJIEN=+ON_","_DFN_",",PSJBCMA=$$GET1^DIQ(55.01,PSJIEN,147,"I"),PSJORIG=$$GET1^DIQ(55.01,PSJIEN,116,"I")
. S DIE="^PS(55,"_DFN_",""IV"",",DA=+ON,DA(1)=DFN
. I PSJBCMA'=1!(PSJORIG'>PSJNOW) D IRA(0) Q
. S PSIVACT=1,DR="116////;.03////"_PSJORIG_";100////A;147////0" D ^DIE
. D IRA(1),EN1^PSJHL2(DFN,"SC",ON,"BCMA REINSTATED")
I ON["U" D Q
. I '$D(^PS(55,DFN,5,+ON)) Q
. I '$P($G(^PS(55,DFN,5,+ON,8)),U,2) N VAIP D IN5^VADPT Q:'$G(VAIP(1))
. S PSJIEN=+ON_","_DFN_",",PSJBCMA=$$GET1^DIQ(55.06,PSJIEN,123,"I"),PSJORIG=$$GET1^DIQ(55.06,PSJIEN,25,"I")
. S DIE="^PS(55,"_DFN_",5,",DA=+ON,DA(1)=DFN
. I PSJBCMA'=1!(PSJORIG'>PSJNOW) D URA(0) Q
. S DR="25////;34////"_PSJORIG_";28////A;123////0" D ^DIE
. D URA(1),EN1^PSJHL2(DFN,"SC",ON,"BCMA REINSTATED")
Q
IEA(STAT) ;
S ON55=ON,PSIVREA="E",PSIVAL=$S(STAT:"BCMA EXPIRED",1:"BCMA EXPIRE DENIED")
D LOG^PSIVORAL Q
UEA(STAT) ;
S PSGAL("C")=$S(STAT:25000,1:25100) D ^PSGAL5 Q
IRA(STAT) ;
S ON55=ON,PSIVREA="E",PSIVAL=$S(STAT:"BCMA REINSTATED",1:"BCMA REINSTATE DENIED")
D LOG^PSIVORAL
F PSJF=.06,135,16 S X=$$GET1^DIQ(55.01,PSJIEN,PSJF,"I") I X]"" S XMY(X)=""
D MSG(STAT)
Q
URA(STAT) ;
S PSGAL("C")=$S(STAT:25200,1:25300) D ^PSGAL5
F PSJF=16,18,20 S X=$$GET1^DIQ(55.06,PSJIEN,PSJF,"I") I X]"" S XMY(X)=""
D MSG(STAT)
Q
MSG(STAT) ;
S XMDUZ="Inpatient Medications",XMSUB="Medication Order"_$S(STAT:"",1:" not")_" reinstated.",XMTEXT="PSJ(",XMY(DUZ)="",XMY("G.PSJ-ORDERS REINSTATED@"_$G(^XMB("NETNAME")))=""
S PSJ(1,0)="Patient: "_$P(^DPT(DFN,0),"^"),PSJ(2,0)="The following order was"_$S(STAT:"",1:" not")_" reinstated after a status change in BCMA."
S PSJLINE=0 I ON["U" D DSPLORDU^PSJLMUT1(DFN,ON)
I ON["V" D DSPLORDV^PSJLMUT1(DFN,ON)
S CNT=2,X="" F S X=$O(PSJOC(ON,X)) Q:X="" S CNT=CNT+1,PSJ(CNT,0)=PSJOC(ON,X)
D ^XMD I $D(XMZ) S DA=XMZ,DIE=3.9,DR="1.7///P;" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBCMA4 3919 printed Sep 23, 2025@19:42:24 Page 2
PSJBCMA4 ;BIR/JLC - BCMA ORDER UPDATE FOR INPATIENT MEDS ;18 JUN 01
+1 ;;5.0;INPATIENT MEDICATIONS ;**63,66,58,104,328**;16 DEC 97;Build 6
+2 ;
+3 ;Reference to ^DPT is supported by DBIA 10035
+4 ;Reference to ^PS(55 is supported by DBIA 2191
+5 ;Reference to ^XMB is supported by DBIA 1131
+6 ;Reference to ^%DTC is supported by DBIA 10000
+7 ;Reference to ^DIE is supported by DBIA 10018
+8 ;Reference to ^DIQ is supported by DBIA 2056
+9 ;Reference to ^XMD is supported by DBIA 10070
+10 ;
ENE(DFN,ON) ;
+1 NEW PSJIEN,PSJSTOP,PSJSTAT,PSJSTOP,PSJNOW,DA,DR,DIE,PSIVACT,ON55,PSIVREA,PSIVAL,PSIVALT,PSJSCH,X
+2 IF $GET(DFN)=""!($GET(ON)="")
QUIT
+3 DO NOW^%DTC
SET PSJNOW=%
+4 IF ON["V"
Begin DoDot:1
+5 IF '$DATA(^PS(55,DFN,"IV",+ON))
QUIT
+6 SET X=$GET(^PS(55,DFN,"IV",+ON,0))
+7 SET PSJSTART=$PIECE(X,"^",2)
SET PSJSTOP=$PIECE(X,"^",3)
SET PSJSCH=$PIECE(X,"^",9)
SET PSJSTAT=$PIECE(X,"^",17)
+8 IF $PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),"^",4)="D"
QUIT
+9 SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=+ON
SET DA(1)=DFN
+10 IF PSJSTAT'="A"
DO IEA(0)
QUIT
+11 IF PSJSTOP'>PSJNOW
DO IEA(0)
QUIT
+12 IF $$ONE^PSJBCMA(DFN,ON,PSJSCH,PSJSTART,PSJSTOP)'="O"
DO IEA(0)
QUIT
+13 SET PSIVACT=1
SET DR="116////"_PSJSTOP_";.03////"_PSJNOW_";100////E;147////1"
DO ^DIE
+14 DO IEA(1)
DO EN1^PSJHL2(DFN,"SC",ON,"BCMA EXPIRED")
End DoDot:1
QUIT
+15 IF ON["U"
Begin DoDot:1
+16 IF '$DATA(^PS(55,DFN,5,+ON))
QUIT
+17 SET X=$GET(^PS(55,DFN,5,+ON,2))
SET PSJSCH=$PIECE(X,"^")
SET PSJSTART=$PIECE(X,"^",2)
SET PSJSTOP=$PIECE(X,"^",4)
+18 SET PSJIEN=+ON_","_DFN_","
SET PSJSTAT=$$GET1^DIQ(55.06,PSJIEN,28,"I")
+19 IF $PIECE($GET(^PS(55,DFN,5,+ON,.2)),"^",4)="D"
QUIT
+20 SET DIE="^PS(55,"_DFN_",5,"
SET DA=+ON
SET DA(1)=DFN
+21 IF PSJSTAT'="A"
DO UEA(0)
QUIT
+22 IF PSJSTOP'>PSJNOW
DO UEA(0)
QUIT
+23 IF $$ONE^PSJBCMA(DFN,ON,PSJSCH,PSJSTART,PSJSTOP)'="O"
DO UEA(0)
QUIT
+24 SET DR="25////"_PSJSTOP_";34////"_PSJNOW_";28////E;123////1"
DO ^DIE
+25 DO UEA(1)
DO EN1^PSJHL2(DFN,"SC",ON,"BCMA EXPIRED")
End DoDot:1
QUIT
+26 QUIT
ENR(DFN,ON) ;
+1 NEW PSJIEN,PSJORIG,PSJSTAT,PSJSTOP,PSJNOW,DA,DR,DIE,PSIVACT,PSJF,X,PSJ,XMY,XMDUZ,XMSUB,XMTEXT
+2 IF $GET(DFN)=""!($GET(ON)="")
QUIT
+3 DO NOW^%DTC
SET PSJNOW=%
+4 IF ON["V"
Begin DoDot:1
+5 IF '$DATA(^PS(55,DFN,"IV",+ON))
QUIT
+6 IF '$PIECE($GET(^PS(55,DFN,"IV",+ON,"DSS")),U,2)
NEW VAIP
DO IN5^VADPT
if '$GET(VAIP(1))
QUIT
+7 SET PSJIEN=+ON_","_DFN_","
SET PSJBCMA=$$GET1^DIQ(55.01,PSJIEN,147,"I")
SET PSJORIG=$$GET1^DIQ(55.01,PSJIEN,116,"I")
+8 SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=+ON
SET DA(1)=DFN
+9 IF PSJBCMA'=1!(PSJORIG'>PSJNOW)
DO IRA(0)
QUIT
+10 SET PSIVACT=1
SET DR="116////;.03////"_PSJORIG_";100////A;147////0"
DO ^DIE
+11 DO IRA(1)
DO EN1^PSJHL2(DFN,"SC",ON,"BCMA REINSTATED")
End DoDot:1
QUIT
+12 IF ON["U"
Begin DoDot:1
+13 IF '$DATA(^PS(55,DFN,5,+ON))
QUIT
+14 IF '$PIECE($GET(^PS(55,DFN,5,+ON,8)),U,2)
NEW VAIP
DO IN5^VADPT
if '$GET(VAIP(1))
QUIT
+15 SET PSJIEN=+ON_","_DFN_","
SET PSJBCMA=$$GET1^DIQ(55.06,PSJIEN,123,"I")
SET PSJORIG=$$GET1^DIQ(55.06,PSJIEN,25,"I")
+16 SET DIE="^PS(55,"_DFN_",5,"
SET DA=+ON
SET DA(1)=DFN
+17 IF PSJBCMA'=1!(PSJORIG'>PSJNOW)
DO URA(0)
QUIT
+18 SET DR="25////;34////"_PSJORIG_";28////A;123////0"
DO ^DIE
+19 DO URA(1)
DO EN1^PSJHL2(DFN,"SC",ON,"BCMA REINSTATED")
End DoDot:1
QUIT
+20 QUIT
IEA(STAT) ;
+1 SET ON55=ON
SET PSIVREA="E"
SET PSIVAL=$SELECT(STAT:"BCMA EXPIRED",1:"BCMA EXPIRE DENIED")
+2 DO LOG^PSIVORAL
QUIT
UEA(STAT) ;
+1 SET PSGAL("C")=$SELECT(STAT:25000,1:25100)
DO ^PSGAL5
QUIT
IRA(STAT) ;
+1 SET ON55=ON
SET PSIVREA="E"
SET PSIVAL=$SELECT(STAT:"BCMA REINSTATED",1:"BCMA REINSTATE DENIED")
+2 DO LOG^PSIVORAL
+3 FOR PSJF=.06,135,16
SET X=$$GET1^DIQ(55.01,PSJIEN,PSJF,"I")
IF X]""
SET XMY(X)=""
+4 DO MSG(STAT)
+5 QUIT
URA(STAT) ;
+1 SET PSGAL("C")=$SELECT(STAT:25200,1:25300)
DO ^PSGAL5
+2 FOR PSJF=16,18,20
SET X=$$GET1^DIQ(55.06,PSJIEN,PSJF,"I")
IF X]""
SET XMY(X)=""
+3 DO MSG(STAT)
+4 QUIT
MSG(STAT) ;
+1 SET XMDUZ="Inpatient Medications"
SET XMSUB="Medication Order"_$SELECT(STAT:"",1:" not")_" reinstated."
SET XMTEXT="PSJ("
SET XMY(DUZ)=""
SET XMY("G.PSJ-ORDERS REINSTATED@"_$GET(^XMB("NETNAME")))=""
+2 SET PSJ(1,0)="Patient: "_$PIECE(^DPT(DFN,0),"^")
SET PSJ(2,0)="The following order was"_$SELECT(STAT:"",1:" not")_" reinstated after a status change in BCMA."
+3 SET PSJLINE=0
IF ON["U"
DO DSPLORDU^PSJLMUT1(DFN,ON)
+4 IF ON["V"
DO DSPLORDV^PSJLMUT1(DFN,ON)
+5 SET CNT=2
SET X=""
FOR
SET X=$ORDER(PSJOC(ON,X))
if X=""
QUIT
SET CNT=CNT+1
SET PSJ(CNT,0)=PSJOC(ON,X)
+6 DO ^XMD
IF $DATA(XMZ)
SET DA=XMZ
SET DIE=3.9
SET DR="1.7///P;"
DO ^DIE
+7 QUIT
