PSJBCMA3 ;BIR/JLC-ADD BCMA STATUS UPDATE TO PS(55 ;21 FEB 01
;;5.0;INPATIENT MEDICATIONS ;**58,91,190,347,400**;16 DEC 97;Build 2
;Reference to ^PS(51.1 is supported by DBIA #2177.
;Reference to ^PS(55 is supported by DBIA 2191
;
EN(DFN,ON,BCID,STATUS,DATE) ;
I '$D(DFN)!'$D(ON)!'$D(BCID)!'$D(STATUS)!'$D(DATE) Q
I '$D(^PS(55,DFN,"IV",ON)) Q
N PSJBLN,UON
D SEARCH(ON)
I $D(PSJBLN) S UON=ON G UPDATE
S (PON,OPON)=ON F S PON=$P(^PS(55,DFN,"IV",PON,2),"^",5) S:PON["P" PON=$$PNDV(PON) S PON=+PON Q:'PON Q:PON=OPON D SEARCH(PON) Q:$D(PSJBLN) S OPON=PON
I $D(PSJBLN) S UON=PON G UPDATE
Q
SEARCH(ON) S X1=0 F S X1=$O(^PS(55,DFN,"IV",ON,"BCMA",X1)) Q:X1=""!(X1'?1.N) I $D(^PS(55,DFN,"IVBCMA",X1)),$P(^(X1,0),"^")=BCID S PSJBLN=X1 Q
Q
UPDATE K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IVBCMA"",",DA=PSJBLN,DA(1)=DFN,DR="1////"_DATE_";2////"_STATUS
I STATUS="" S DR="1///@;2///@"
D ^DIE
K DA,DR,DIE S DIE="^PS(55,"_DFN_",""IV"",",DA=UON,DA(1)=DFN,DR="144////"_STATUS_";145////"_BCID
I STATUS="" S DR="144///@;145///@"
D ^DIE
Q
;
PNDV(PNDON) ;
Q:PNDON'["P" ""
N PRV S PRV=""
F S PRV=$P($G(^PS(53.1,+PNDON,0)),"^",25) Q:PRV=""!(PRV["V") S PNDON=PRV
Q $S(PRV["V":PRV,1:"")
;
OTPRN(SCH1) ; Determine if this order is a one-time PRN PSJ*5*190
N SCH2 S TYP=""
;actual schedule of "x PRN" exists in schedule file. Don't remove PRN from it.
I $D(^PS(51.1,"AC","PSJ",SCH1)) D Q $G(TYP)
.S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,"")) Q:'$D(^PS(51.1,SCH2)) ; p400 changed from Q:'$D(^PS(53.1,SCH2))
.S TYP=$P($G(^PS(51.1,SCH2,0)),"^",5)
S SCH1=$P(SCH1," PRN",1)
I SCH1="" Q ""
I '$D(^PS(51.1,"AC","PSJ",SCH1)) Q ""
S SCH2=$O(^PS(51.1,"AC","PSJ",SCH1,""))
I '$D(^PS(51.1,SCH2)) Q ""
Q $P($G(^PS(51.1,SCH2,0)),"^",5)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBCMA3 1779 printed Dec 13, 2024@02:06:16 Page 2
PSJBCMA3 ;BIR/JLC-ADD BCMA STATUS UPDATE TO PS(55 ;21 FEB 01
+1 ;;5.0;INPATIENT MEDICATIONS ;**58,91,190,347,400**;16 DEC 97;Build 2
+2 ;Reference to ^PS(51.1 is supported by DBIA #2177.
+3 ;Reference to ^PS(55 is supported by DBIA 2191
+4 ;
EN(DFN,ON,BCID,STATUS,DATE) ;
+1 IF '$DATA(DFN)!'$DATA(ON)!'$DATA(BCID)!'$DATA(STATUS)!'$DATA(DATE)
QUIT
+2 IF '$DATA(^PS(55,DFN,"IV",ON))
QUIT
+3 NEW PSJBLN,UON
+4 DO SEARCH(ON)
+5 IF $DATA(PSJBLN)
SET UON=ON
GOTO UPDATE
+6 SET (PON,OPON)=ON
FOR
SET PON=$PIECE(^PS(55,DFN,"IV",PON,2),"^",5)
if PON["P"
SET PON=$$PNDV(PON)
SET PON=+PON
if 'PON
QUIT
if PON=OPON
QUIT
DO SEARCH(PON)
if $DATA(PSJBLN)
QUIT
SET OPON=PON
+7 IF $DATA(PSJBLN)
SET UON=PON
GOTO UPDATE
+8 QUIT
SEARCH(ON) SET X1=0
FOR
SET X1=$ORDER(^PS(55,DFN,"IV",ON,"BCMA",X1))
if X1=""!(X1'?1.N)
QUIT
IF $DATA(^PS(55,DFN,"IVBCMA",X1))
IF $PIECE(^(X1,0),"^")=BCID
SET PSJBLN=X1
QUIT
+1 QUIT
UPDATE KILL DA,DR,DIE
SET DIE="^PS(55,"_DFN_",""IVBCMA"","
SET DA=PSJBLN
SET DA(1)=DFN
SET DR="1////"_DATE_";2////"_STATUS
+1 IF STATUS=""
SET DR="1///@;2///@"
+2 DO ^DIE
+3 KILL DA,DR,DIE
SET DIE="^PS(55,"_DFN_",""IV"","
SET DA=UON
SET DA(1)=DFN
SET DR="144////"_STATUS_";145////"_BCID
+4 IF STATUS=""
SET DR="144///@;145///@"
+5 DO ^DIE
+6 QUIT
+7 ;
PNDV(PNDON) ;
+1 if PNDON'["P"
QUIT ""
+2 NEW PRV
SET PRV=""
+3 FOR
SET PRV=$PIECE($GET(^PS(53.1,+PNDON,0)),"^",25)
if PRV=""!(PRV["V")
QUIT
SET PNDON=PRV
+4 QUIT $SELECT(PRV["V":PRV,1:"")
+5 ;
OTPRN(SCH1) ; Determine if this order is a one-time PRN PSJ*5*190
+1 NEW SCH2
SET TYP=""
+2 ;actual schedule of "x PRN" exists in schedule file. Don't remove PRN from it.
+3 IF $DATA(^PS(51.1,"AC","PSJ",SCH1))
Begin DoDot:1
+4 ; p400 changed from Q:'$D(^PS(53.1,SCH2))
SET SCH2=$ORDER(^PS(51.1,"AC","PSJ",SCH1,""))
if '$DATA(^PS(51.1,SCH2))
QUIT
+5 SET TYP=$PIECE($GET(^PS(51.1,SCH2,0)),"^",5)
End DoDot:1
QUIT $GET(TYP)
+6 SET SCH1=$PIECE(SCH1," PRN",1)
+7 IF SCH1=""
QUIT ""
+8 IF '$DATA(^PS(51.1,"AC","PSJ",SCH1))
QUIT ""
+9 SET SCH2=$ORDER(^PS(51.1,"AC","PSJ",SCH1,""))
+10 IF '$DATA(^PS(51.1,SCH2))
QUIT ""
+11 QUIT $PIECE($GET(^PS(51.1,SCH2,0)),"^",5)
