- 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 Jan 18, 2025@03:07:30 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)