- PSJLMPRI ;BIR/MLM - INPATIENT LISTMAN IV PROFILE UTILITIES ;Jul 05, 2018@13:46
- ;;5.0;INPATIENT MEDICATIONS;**58,85,118,110,133,154,181,275,373**;16 DEC 97;Build 3
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ;
- PIV(DFN,ON,PSJF,DN) ;Setup LM display for IV order.
- N ND14,DRG,ON55,P,PSJORIFN,TYP,V,X,Y,PSJFLAG,ND4 S TYP="?" I ON["V" D
- .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23,25 S P(X)=$P(Y,U,X)
- .S TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3)) I TYP'="O" S TYP="C"
- .S ON55=ON,P("OT")=$S(P(4)="A":"F",P(4)="H":"H",1:"I") D GTDRG^PSIVORFB,GTOT^PSIVUTL(P(4))
- .S P("PRY")=$P($G(^PS(55,DFN,"IV",+ON,.2)),U,4),PSJFLAG=$P($G(^(.2)),U,7)
- .S ND4=$G(^PS(55,DFN,"IV",+ON,4)),V=$S(P("PRY")="D":"d",1:" ")_$S((+PSJSYSU=1&'+$P(ND4,U)):"->",(+PSJSYSU=3&'+$P(ND4,U,4)):"->",1:"") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
- .S PSJL=$$SETSTR^VALM1(V,PSJL,6,3)
- .S ND14=$G(^PS(55,DFN,"IV",+ON,14,0)),ND14=$P(ND14,U,3) S:ND14 ND14=+$G(^(ND14,0))
- I ON=+ON N PSJEN2,O S PSJEN2=PSJEN,O="" F S O=$O(^PS(53.1,"ACX",ON,O)) Q:O="" D
- .I PSJEN2'=PSJEN S PSJL=$J(PSJEN2,4)
- .S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+O,O)),U,9),Y=+$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U),PSJFLAG=$P($G(^(.2)),U,7)
- .D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4)) D @$S($E(P("OT"))'="F":"PUD^PSJLMPRU(DFN,O_""P"",PSJF,DN)",1:"PIV^PSJLMPRI(DFN,O_""P"",PSJF,DN)") S PSJEN2=""
- I ON["P" S (P(2),P(3))="",P(17)=$P($G(^PS(53.1,+ON,0)),U,9),Y=$G(^(8)),P(4)=$P(Y,U),P(8)=$P(Y,U,5),P(9)=$P($G(^(2)),U),PSJFLAG=$P($G(^(.2)),U,7) D I $E(P("OT"))'="F" D PUD^PSJLMPRU(DFN,ON,PSJF,DN) Q
- . D GTDRG^PSIVORFA,GTOT^PSIVUTL(P(4))
- . S ND14=$G(^PS(53.1,+ON,14,0)),ND14=$P(ND14,U,3) S:ND14 ND14=+$G(^(ND14,0))
- I $G(PSJFLAG) D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
- NEW PSJIVFLG S PSJIVFLG=1
- S DRG=+$O(DRG("AD",0)) D:DRG PIVAD F S DRG=$O(DRG("AD",DRG)) Q:'DRG S PSJL="" D PIVAD
- SOL ;
- S PSJL=$S($G(PSJIVFLG):PSJL_$S(ON["V":"in",1:" in"),1:" in")
- NEW DRGX,NAME
- ; #373 - Added dot notation (prompted by new call to RENEWDT API) beginning on next line to avoid ln longer than 245 bytes issue.
- S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D
- . D NAME^PSIVUTL(DRG("SOL",DRG),33,.NAME,0)
- . S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX D
- .. S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,33)
- .. D:'$G(PSJIVFLG) RENEWDT D:$G(PSJIVFLG) PIV1
- .. D SETTMP,SETSTAT S PSJL=" "
- ;S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:'$G(PSJIVFLG) SETTMP D:$G(PSJIVFLG) PIV1 S PSJL=" "
- D RENEWDT I PSJL["Renewed" D SETTMP,SETSTAT ; #373 - in case only one output line, get RENEW info, if any.
- Q
- PIVAD ; Print IV Additives.
- NEW NAME
- D NAME^PSIVUTL(DRG("AD",DRG),34,.NAME,1) ; #373 - Changed length to 34 from 39
- ; #373 - Added calls to RENEWDT API in two lines immediately below.
- I $D(NAME(2)) S PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,34) D:'$G(PSJIVFLG) RENEWDT D:$G(PSJIVFLG) PIV1 D SETTMP,SETSTAT S PSJL="",PSJL=$$SETSTR^VALM1(NAME(2),PSJL,9,34) D RENEWDT,SETTMP,SETSTAT
- I '$D(NAME(2)) S PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,34) D:'$G(PSJIVFLG) RENEWDT D:$G(PSJIVFLG) PIV1 D SETTMP,SETSTAT
- Q
- ;
- PIV1 ; Print Sched type, start/stop dates, and status.
- ;K PSJIVFLG,PSJCLP I $G(PSJCLORD),$G(ON)["P" N PSJCLP S PSJCLP(2)=$P(^PS(53.1,+ON,2),"^",2),PSJCLP(3)=$P(^PS(53.1,+ON,2),"^",4) F X=2,3 S PSJCLP(X)=$E($$ENDTC^PSGMI(PSJCLP(X)),1,$S($D(PSJEXTP):8,1:5)) ;#373
- K PSJIVFLG,PSJCLP I $G(PSJCLORD),$G(ON)["P" N PSJCLP S PSJCLP(2)=$P(^PS(53.1,+ON,2),"^",2),PSJCLP(3)=$P(^PS(53.1,+ON,2),"^",4) F X=2,3 S PSJCLP(X)=$E($$ENDTC2^PSGMI(PSJCLP(X)),1,$S($D(PSJEXTP):8,1:10)) ;#373
- ;F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) ;#373
- F X=2,3 S P(X)=$E($$ENDTC2^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:10)) ;#373
- ;I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),PSJL,53,7) D ;#373
- ;.S PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,7),PSJL=$$SETSTR^VALM1($S($G(P(25))]"":P(25),1:P(17)),PSJL,66,2) ;#373
- ;E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
- ; ,PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),53,7)
- ; ,PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,63,7)
- ; ,PSJL=$$SETSTR^VALM1($S(PSJOL'="L"&($G(P(25))]""):P(25),1:P(17)),PSJL,73,2) ;#373 (line too long so breaking into dot structure necessary)
- I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,46,1),PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),PSJL,49,10) D ;#373
- . S PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,10),PSJL=$$SETSTR^VALM1($S($G(P(25))]"":P(25),1:P(17)),PSJL,71,2) ;#373
- E D ;#373
- . S PSJL=$$SETSTR^VALM1(TYP,PSJL,46,1) ;#373
- . S PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),49,10) ;#373
- . S PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,10) ;#373
- . S PSJL=$$SETSTR^VALM1($S(PSJOL'="L"&($G(P(25))]""):P(25),1:P(17)),PSJL,71,2) ;#373
- ;I $G(ND14) S ND14=$$ENDTC^PSGMI((ND14)) S PSJL=$$SETSTR^VALM1(ND14,PSJL,$S($D(PSJEXTP):75,1:72),5) K ND14 ;#373
- ;* D SETTMP
- Q
- RENEWDT ; 373 - Put renewal date on 2nd line instead of 1st.
- Q:$G(ND14)']"" S PSJL=$$SETSTR^VALM1("Renewed:",PSJL,49,8)
- S ND14=$$ENDTC2^PSGMI((ND14)) S PSJL=$$SETSTR^VALM1(ND14,PSJL,58,10) K ND14
- Q
- ;
- SETTMP ;
- S ^TMP($S($G(PSIVLBNM)]"":PSIVLBNM,1:"PSJPRO"),$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
- Q
- ;
- SETSTAT ;
- I ON["P",$P($G(^PS(53.1,+ON,.2)),"^",4)="S" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0)
- Q
- ;
- LASTREN(DFN,ON) ;
- N FIL,RNDT,ND0,ND14 S ND14="" I '$G(ON)!'$G(DFN) Q 0
- S FIL=$S(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
- ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
- Q:FIL="" 0
- S ND14=$G(@(FIL)) I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0))
- Q ND14
- ;
- LASTRNBY(DFN,ON) ;
- N FIL,RNBY,ND0,ND14 S RNBY=""
- S FIL=$S(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
- ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
- Q:FIL="" 0
- S ND14=$G(@(FIL)) I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNBY=$P(ND14,"^",2)
- Q RNBY
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLMPRI 6525 printed Feb 18, 2025@23:33:53 Page 2
- PSJLMPRI ;BIR/MLM - INPATIENT LISTMAN IV PROFILE UTILITIES ;Jul 05, 2018@13:46
- +1 ;;5.0;INPATIENT MEDICATIONS;**58,85,118,110,133,154,181,275,373**;16 DEC 97;Build 3
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ;
- PIV(DFN,ON,PSJF,DN) ;Setup LM display for IV order.
- +1 NEW ND14,DRG,ON55,P,PSJORIFN,TYP,V,X,Y,PSJFLAG,ND4
- SET TYP="?"
- IF ON["V"
- Begin DoDot:1
- +2 SET Y=$GET(^PS(55,DFN,"IV",+ON,0))
- FOR X=2,3,4,5,8,9,17,23,25
- SET P(X)=$PIECE(Y,U,X)
- +3 SET TYP=$$ONE^PSJBCMA(DFN,ON,P(9),P(2),P(3))
- IF TYP'="O"
- SET TYP="C"
- +4 SET ON55=ON
- SET P("OT")=$SELECT(P(4)="A":"F",P(4)="H":"H",1:"I")
- DO GTDRG^PSIVORFB
- DO GTOT^PSIVUTL(P(4))
- +5 SET P("PRY")=$PIECE($GET(^PS(55,DFN,"IV",+ON,.2)),U,4)
- SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
- +6 SET ND4=$GET(^PS(55,DFN,"IV",+ON,4))
- SET V=$SELECT(P("PRY")="D":"d",1:" ")_$SELECT((+PSJSYSU=1&'+$PIECE(ND4,U)):"->",(+PSJSYSU=3&'+$PIECE(ND4,U,4)):"->",1:"")
- IF PSJFLAG
- DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
- +7 SET PSJL=$$SETSTR^VALM1(V,PSJL,6,3)
- +8 SET ND14=$GET(^PS(55,DFN,"IV",+ON,14,0))
- SET ND14=$PIECE(ND14,U,3)
- if ND14
- SET ND14=+$GET(^(ND14,0))
- End DoDot:1
- +9 IF ON=+ON
- NEW PSJEN2,O
- SET PSJEN2=PSJEN
- SET O=""
- FOR
- SET O=$ORDER(^PS(53.1,"ACX",ON,O))
- if O=""
- QUIT
- Begin DoDot:1
- +10 IF PSJEN2'=PSJEN
- SET PSJL=$JUSTIFY(PSJEN2,4)
- +11 SET (P(2),P(3))=""
- SET P(17)=$PIECE($GET(^PS(53.1,+O,O)),U,9)
- SET Y=+$GET(^(8))
- SET P(4)=$PIECE(Y,U)
- SET P(8)=$PIECE(Y,U,5)
- SET P(9)=$PIECE($GET(^(2)),U)
- SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
- +12 DO GTDRG^PSIVORFA
- DO GTOT^PSIVUTL(P(4))
- DO @$SELECT($EXTRACT(P("OT"))'="F":"PUD^PSJLMPRU(DFN,O_""P"",PSJF,DN)",1:"PIV^PSJLMPRI(DFN,O_""P"",PSJF,DN)")
- SET PSJEN2=""
- End DoDot:1
- +13 IF ON["P"
- SET (P(2),P(3))=""
- SET P(17)=$PIECE($GET(^PS(53.1,+ON,0)),U,9)
- SET Y=$GET(^(8))
- SET P(4)=$PIECE(Y,U)
- SET P(8)=$PIECE(Y,U,5)
- SET P(9)=$PIECE($GET(^(2)),U)
- SET PSJFLAG=$PIECE($GET(^(.2)),U,7)
- Begin DoDot:1
- +14 DO GTDRG^PSIVORFA
- DO GTOT^PSIVUTL(P(4))
- +15 SET ND14=$GET(^PS(53.1,+ON,14,0))
- SET ND14=$PIECE(ND14,U,3)
- if ND14
- SET ND14=+$GET(^(ND14,0))
- End DoDot:1
- IF $EXTRACT(P("OT"))'="F"
- DO PUD^PSJLMPRU(DFN,ON,PSJF,DN)
- QUIT
- +16 IF $GET(PSJFLAG)
- DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
- +17 NEW PSJIVFLG
- SET PSJIVFLG=1
- +18 SET DRG=+$ORDER(DRG("AD",0))
- if DRG
- DO PIVAD
- FOR
- SET DRG=$ORDER(DRG("AD",DRG))
- if 'DRG
- QUIT
- SET PSJL=""
- DO PIVAD
- SOL ;
- +1 SET PSJL=$SELECT($GET(PSJIVFLG):PSJL_$SELECT(ON["V":"in",1:" in"),1:" in")
- +2 NEW DRGX,NAME
- +3 ; #373 - Added dot notation (prompted by new call to RENEWDT API) beginning on next line to avoid ln longer than 245 bytes issue.
- +4 SET DRG=0
- FOR
- SET DRG=+$ORDER(DRG("SOL",DRG))
- if 'DRG
- QUIT
- Begin DoDot:1
- +5 DO NAME^PSIVUTL(DRG("SOL",DRG),33,.NAME,0)
- +6 SET DRGX=0
- FOR
- SET DRGX=$ORDER(NAME(DRGX))
- if 'DRGX
- QUIT
- Begin DoDot:2
- +7 SET PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,33)
- +8 if '$GET(PSJIVFLG)
- DO RENEWDT
- if $GET(PSJIVFLG)
- DO PIV1
- +9 DO SETTMP
- DO SETSTAT
- SET PSJL=" "
- End DoDot:2
- End DoDot:1
- +10 ;S DRG=0 F S DRG=+$O(DRG("SOL",DRG)) Q:'DRG D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F S DRGX=$O(NAME(DRGX)) Q:'DRGX S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:'$G(PSJIVFLG) SETTMP D:$G(PSJIVFLG) PIV1 S PSJL=" "
- +11 ; #373 - in case only one output line, get RENEW info, if any.
- DO RENEWDT
- IF PSJL["Renewed"
- DO SETTMP
- DO SETSTAT
- +12 QUIT
- PIVAD ; Print IV Additives.
- +1 NEW NAME
- +2 ; #373 - Changed length to 34 from 39
- DO NAME^PSIVUTL(DRG("AD",DRG),34,.NAME,1)
- +3 ; #373 - Added calls to RENEWDT API in two lines immediately below.
- +4 IF $DATA(NAME(2))
- SET PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,34)
- if '$GET(PSJIVFLG)
- DO RENEWDT
- if $GET(PSJIVFLG)
- DO PIV1
- DO SETTMP
- DO SETSTAT
- SET PSJL=""
- SET PSJL=$$SETSTR^VALM1(NAME(2),PSJL,9,34)
- DO RENEWDT
- DO SETTMP
- DO SETSTAT
- +5 IF '$DATA(NAME(2))
- SET PSJL=$$SETSTR^VALM1(NAME(1),PSJL,9,34)
- if '$GET(PSJIVFLG)
- DO RENEWDT
- if $GET(PSJIVFLG)
- DO PIV1
- DO SETTMP
- DO SETSTAT
- +6 QUIT
- +7 ;
- PIV1 ; Print Sched type, start/stop dates, and status.
- +1 ;K PSJIVFLG,PSJCLP I $G(PSJCLORD),$G(ON)["P" N PSJCLP S PSJCLP(2)=$P(^PS(53.1,+ON,2),"^",2),PSJCLP(3)=$P(^PS(53.1,+ON,2),"^",4) F X=2,3 S PSJCLP(X)=$E($$ENDTC^PSGMI(PSJCLP(X)),1,$S($D(PSJEXTP):8,1:5)) ;#373
- +2 ;#373
- KILL PSJIVFLG,PSJCLP
- IF $GET(PSJCLORD)
- IF $GET(ON)["P"
- NEW PSJCLP
- SET PSJCLP(2)=$PIECE(^PS(53.1,+ON,2),"^",2)
- SET PSJCLP(3)=$PIECE(^PS(53.1,+ON,2),"^",4)
- FOR X=2,3
- SET PSJCLP(X)=$EXTRACT($$ENDTC2^PSGMI(PSJCLP(X)),1,$SELECT($DATA(PSJEXTP):8,1:10))
- +3 ;F X=2,3 S P(X)=$E($$ENDTC^PSGMI(P(X)),1,$S($D(PSJEXTP):8,1:5)) ;#373
- +4 ;#373
- FOR X=2,3
- SET P(X)=$EXTRACT($$ENDTC2^PSGMI(P(X)),1,$SELECT($DATA(PSJEXTP):8,1:10))
- +5 ;I '$D(PSJEXTP) S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),PSJL,53,7) D ;#373
- +6 ;.S PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,7),PSJL=$$SETSTR^VALM1($S($G(P(25))]"":P(25),1:P(17)),PSJL,66,2) ;#373
- +7 ;E S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1)
- +8 ; ,PSJL=$$SETSTR^VALM1($S($G(PSJCLP(2)):PSJCLP(2),1:P(2)),53,7)
- +9 ; ,PSJL=$$SETSTR^VALM1($S($G(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,63,7)
- +10 ; ,PSJL=$$SETSTR^VALM1($S(PSJOL'="L"&($G(P(25))]""):P(25),1:P(17)),PSJL,73,2) ;#373 (line too long so breaking into dot structure necessary)
- +11 ;#373
- IF '$DATA(PSJEXTP)
- SET PSJL=$$SETSTR^VALM1(TYP,PSJL,46,1)
- SET PSJL=$$SETSTR^VALM1($SELECT($GET(PSJCLP(2)):PSJCLP(2),1:P(2)),PSJL,49,10)
- Begin DoDot:1
- +12 ;#373
- SET PSJL=$$SETSTR^VALM1($SELECT($GET(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,10)
- SET PSJL=$$SETSTR^VALM1($SELECT($GET(P(25))]"":P(25),1:P(17)),PSJL,71,2)
- End DoDot:1
- +13 ;#373
- IF '$TEST
- Begin DoDot:1
- +14 ;#373
- SET PSJL=$$SETSTR^VALM1(TYP,PSJL,46,1)
- +15 ;#373
- SET PSJL=$$SETSTR^VALM1($SELECT($GET(PSJCLP(2)):PSJCLP(2),1:P(2)),49,10)
- +16 ;#373
- SET PSJL=$$SETSTR^VALM1($SELECT($GET(PSJCLP(3)):PSJCLP(3),1:P(3)),PSJL,60,10)
- +17 ;#373
- SET PSJL=$$SETSTR^VALM1($SELECT(PSJOL'="L"&($GET(P(25))]""):P(25),1:P(17)),PSJL,71,2)
- End DoDot:1
- +18 ;I $G(ND14) S ND14=$$ENDTC^PSGMI((ND14)) S PSJL=$$SETSTR^VALM1(ND14,PSJL,$S($D(PSJEXTP):75,1:72),5) K ND14 ;#373
- +19 ;* D SETTMP
- +20 QUIT
- RENEWDT ; 373 - Put renewal date on 2nd line instead of 1st.
- +1 if $GET(ND14)']""
- QUIT
- SET PSJL=$$SETSTR^VALM1("Renewed:",PSJL,49,8)
- +2 SET ND14=$$ENDTC2^PSGMI((ND14))
- SET PSJL=$$SETSTR^VALM1(ND14,PSJL,58,10)
- KILL ND14
- +3 QUIT
- +4 ;
- SETTMP ;
- +1 SET ^TMP($SELECT($GET(PSIVLBNM)]"":PSIVLBNM,1:"PSJPRO"),$JOB,PSJLN,0)=PSJL
- SET PSJLN=PSJLN+1
- +2 QUIT
- +3 ;
- SETSTAT ;
- +1 IF ON["P"
- IF $PIECE($GET(^PS(53.1,+ON,.2)),"^",4)="S"
- DO CNTRL^VALM10((PSJLN-1),9,9+$LENGTH(PSJL),IOINHI_IOBON,IOINORM,0)
- +2 QUIT
- +3 ;
- LASTREN(DFN,ON) ;
- +1 NEW FIL,RNDT,ND0,ND14
- SET ND14=""
- IF '$GET(ON)!'$GET(DFN)
- QUIT 0
- +2 SET FIL=$SELECT(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
- +3 ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
- +4 if FIL=""
- QUIT 0
- +5 SET ND14=$GET(@(FIL))
- IF $PIECE(ND14,"^",3)
- SET ND14=$GET(^($PIECE(ND14,"^",3),0))
- +6 QUIT ND14
- +7 ;
- LASTRNBY(DFN,ON) ;
- +1 NEW FIL,RNBY,ND0,ND14
- SET RNBY=""
- +2 SET FIL=$SELECT(ON["P":"^PS(53.1,"_+ON_",14,0)",ON["V":"^PS(55,"_DFN_",""IV"","_+ON_",14,0)",ON["U":"^PS(55,"_DFN_",5,"_+ON_",14,0)",1:"")
- +3 ; Naked reference below refers to either ^PS(53.1,+ON,14,0), ^PS(55,+ON,5,14,0), or ^PS(55,+ON,5,14,0) created using indirection in variable FIL.
- +4 if FIL=""
- QUIT 0
- +5 SET ND14=$GET(@(FIL))
- IF $PIECE(ND14,"^",3)
- SET ND14=$GET(^($PIECE(ND14,"^",3),0))
- SET RNBY=$PIECE(ND14,"^",2)
- +6 QUIT RNBY