PSJLMPRU ;BIR/MLM - INPATIENT LISTMAN UD PROFILE UTILITIES ; 1/6/20 11:10am
;;5.0;INPATIENT MEDICATIONS;**16,58,85,110,185,181,267,323,317,373,327,398**;16 DEC 97;Build 3
;
; Reference to ^PSDRUG is supported by DBIA 2192.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to $$GET^XPAR is supported by DBIA 2263
;
PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
N PSJFLAG,PSJV,PADE
; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection.
S ND=$G(@(PSJF_+ON_",0)")),SCH=$G(^(2)),ND4=$G(^(4)),ND6=$G(^(6)),NDP2=$G(^(.2)),PSJFLAG=$P(NDP2,U,7),X=$P(DN,U,2),DO=$S('X:"",1:$G(^(+X))) S:X=.2 DO=$P(DO,U,2)
S ND14=$G(@(PSJF_+ON_",14,0)")),RNDT="" I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^")
I ("AO"[PSJC)!(PSJC="DF") D
.S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",19)&$P(ND4,"^",18):"H",$P(ND4,"^",23)&$P(ND4,"^",22):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
.S PSJV=$S($P(NDP2,U,4)="D":"d",1:" ")_$S(+PSJSYSU=1&V:"->",+PSJSYSU=3&V:"->",1:" ") I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
.S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($P(ND,U,28)]"":$P(ND,U,28),$P(ND,"^",9)]"":$P(ND,"^",9),1:"NF"),PF=$E("*",$P(ND,"^",20)>0),PSGID=$P(SCH,"^",2),SD=$P(SCH,"^",4),SCH=$P(SCH,"^")
I STAT="A",$P(ND,U,27)="R" S STAT="R"
S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
I $D(PSJCLIN) S WS=0 ; PSJ*5*323
; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier
S PADE=0 I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") D
.N PSJORCL,PSJCLNK
.; If clinic order, quit if clinic location is not linked to PADE
.S PSJORCL=$S($G(ON)["P":$G(^PS(53.1,+$G(ON),"DSS")),$G(ON)["U":$G(^PS(55,+$G(PSGP),5,+$G(ON),8)),$G(ON)["V":$G(^PS(55,+$G(PSGP),"IV",+$G(ON),"DSS")),1:"")
.I PSJORCL,$P(PSJORCL,"^",2) S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
.I '$G(VAIN(4)) N VAIN D INP^VADPT
.I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
.S PADE=$$DRGFLAG^PSJPADSI(PSGP,$G(ON),,$G(ON),$G(PSJNEWOE)) S:PADE=0 PADE=1
N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP D
.I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1
;NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5) ;#373
NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:10) ;#373
; START NCC REMEDIATION RJS-327
I $$ISCLOZ^PSJCLOZ(,,DFN,+ON) D
.; REMOVED THE BELOW CODE WITH 398 - PULLING WRONG STOP DATE.
.;D DISPCMP^PSJCLOZ(+$G(ND),.PSSD) S:$G(PSSD) SD=PSSD K PSSD
.D DISPCMP^PSJCLOZ(+$G(ND),.PSSD) S:'$G(SD)&$G(PSSD) SD=PSSD K PSSD
; END NCC REMEDIATION RJS-327
;F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN)) ;#373
F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC2^PSGMI(@X),1,LEN)) ;#373
;D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) ;#373
D DRGDISP^PSJLMUT1(PSGP,ON,33,27,.DRUGNAME,0) ;#373
S RNDTPRT=0 ;#373
F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D
.I PSJX=1 D
..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,46,3) ;#373
..;S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1,2)_$S($L(STAT)=1:" ",1:" ")_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"") ;#373
..S PSJL=$$SETSTR^VALM1(PSGID1,PSJL,49,10),PSJL=$$SETSTR^VALM1(SD1,PSJL,60,10) ;#373
..S PSJL=$$SETSTR^VALM1($E(STAT,1,2)_$S($L(STAT)=1:" ",1:""),PSJL,71,2) ;#373
..;S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1,2)_$S($L(STAT)=1:" ",1:" ")
..;I NF!WS!SM!PF!$G(PADE) S PSJL=$$SETSTR^VALM1($S(NF:"NF ",(WS&PADE):"WP ",(PADE&'WS):"PD ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1) ;#373
..I NF!WS!SM!PF!$G(PADE) S PSJL=$$SETSTR^VALM1($S(NF:"NF ",(WS&PADE):"WP ",(PADE&'WS):"PD ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,74,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,78,1) ;#373
. I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,33)
. I PSJX=2 D RNDTDSP ;#373 - Renewal Date logic added for Unit Dose
. ;I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66) ; #373
. D SETTMP("PSJPRO",PSJL) I ($P(NDP2,U,4)="S"),STAT="P" D CNTRL^VALM10((PSJLN-1),9,9+$L(PSJL),IOINHI_IOBON,IOINORM,0)
I 'RNDTPRT S PSJL="" D RNDTDSP D:RNDTPRT SETTMP("PSJPRO",PSJL) ;#373
I ND6'="" N X,PSJTXT3 S X=$$GETSIOPI^PSJBCMA5(DFN,ON) N TXTLN S TXTLN=0 F S TXTLN=$O(^PS(53.45,DUZ,5,TXTLN)) Q:'TXTLN!$G(PSJTXT3) D
.I ($O(^PS(53.45,DUZ,5," "),-1)>3) S PSJTXT3=1 S PSJL="Instructions too long. See Order View for full text." D PTXT(PSJL,"PSJPRO",10,66) Q
.S PSJL=^PS(53.45,DUZ,5,TXTLN,0) D PTXT(PSJL,"PSJPRO",10,66)
K RNDTPRT ;#373
K ^PS(53.45,DUZ,5)
Q
;
RNDTDSP ; Display Renewal Date - #373
NEW RNDTDSP S RNDTDSP=$S($G(RNDT):$E($$ENDTC2^PSGMI(RNDT),1,LEN),1:"")
I RNDTDSP]"" D
. S PSJL=$$SETSTR^VALM1("Renewed:",PSJL,49,8)
. S PSJL=$$SETSTR^VALM1(RNDTDSP,PSJL,58,10)
. S RNDTPRT=1
Q
;
PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered.
;* Input: TXT = Text to display.
; SUB = First subscript for ^TMP node, ** MUST be PSJ namespace **
; LM = Begin display of text after LM spaces.
; RM = Length of display text.
;
;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.
;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D
S PSJL="",$P(PSJL," ",LM)=""
F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D
.;BHW;PSJ*5*185;check if end of string or just extra space
.I WRD="" S PSJL=PSJL_" " Q
.I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
.I $L(PSJL_" "_WRD)'<RM S PSJL=PSJL_" "_$E(WRD,1,(RM-10)) D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="",WRD=$E(WRD,(RM-9),$L(WRD))
.S PSJL=PSJL_" "_WRD
D SETTMP(SUB,PSJL)
Q
SETTMP(SUB,PSJL) ;
S ^TMP(SUB,$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLMPRU 6224 printed Sep 23, 2025@19:43:37 Page 2
PSJLMPRU ;BIR/MLM - INPATIENT LISTMAN UD PROFILE UTILITIES ; 1/6/20 11:10am
+1 ;;5.0;INPATIENT MEDICATIONS;**16,58,85,110,185,181,267,323,317,373,327,398**;16 DEC 97;Build 3
+2 ;
+3 ; Reference to ^PSDRUG is supported by DBIA 2192.
+4 ; Reference to ^PS(55 is supported by DBIA 2191.
+5 ; Reference to $$GET^XPAR is supported by DBIA 2263
+6 ;
PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
+1 NEW PSJFLAG,PSJV,PADE
+2 ; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection.
+3 SET ND=$GET(@(PSJF_+ON_",0)"))
SET SCH=$GET(^(2))
SET ND4=$GET(^(4))
SET ND6=$GET(^(6))
SET NDP2=$GET(^(.2))
SET PSJFLAG=$PIECE(NDP2,U,7)
SET X=$PIECE(DN,U,2)
SET DO=$SELECT('X:"",1:$GET(^(+X)))
if X=.2
SET DO=$PIECE(DO,U,2)
+4 SET ND14=$GET(@(PSJF_+ON_",14,0)"))
SET RNDT=""
IF $PIECE(ND14,"^",3)
SET ND14=$GET(^($PIECE(ND14,"^",3),0))
SET RNDT=$PIECE(ND14,"^")
+5 IF ("AO"[PSJC)!(PSJC="DF")
Begin DoDot:1
+6 SET V='$PIECE(ND4,"^",UDU)
SET PSJL=$$SETSTR^VALM1($SELECT(ND4="":" ",$PIECE(ND4,"^",12):"D",$PIECE(ND4,"^",19)&$PIECE(ND4,"^",18):"H",$PIECE(ND4,"^",23)&$PIECE(ND4,"^",22):"H",$PIECE(ND4,"^",15)&($PIECE(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
+7 SET PSJV=$SELECT($PIECE(NDP2,U,4)="D":"d",1:" ")_$SELECT(+PSJSYSU=1&V:"->",+PSJSYSU=3&V:"->",1:" ")
IF PSJFLAG
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+8 SET PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
End DoDot:1
+9 SET RTE=$PIECE(ND,"^",3)
SET SM=$SELECT('$PIECE(ND,"^",5):0,$PIECE(ND,"^",6):1,1:2)
SET STAT=$SELECT($PIECE(ND,U,28)]"":$PIECE(ND,U,28),$PIECE(ND,"^",9)]"":$PIECE(ND,"^",9),1:"NF")
SET PF=$EXTRACT("*",$PIECE(ND,"^",20)>0)
SET PSGID=$PIECE(SCH,"^",2)
SET SD=$PIECE(SCH,"^",4)
SET SCH=$PIECE(SCH,"^")
+10 IF STAT="A"
IF $PIECE(ND,U,27)="R"
SET STAT="R"
+11 SET NF=""
SET WS=$SELECT(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
+12 ; PSJ*5*323
IF $DATA(PSJCLIN)
SET WS=0
+13 ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier
+14 SET PADE=0
IF $$GET^XPAR("SYS","PSJ PADE OE BALANCES")
Begin DoDot:1
+15 NEW PSJORCL,PSJCLNK
+16 ; If clinic order, quit if clinic location is not linked to PADE
+17 SET PSJORCL=$SELECT($GET(ON)["P":$GET(^PS(53.1,+$GET(ON),"DSS")),$GET(ON)["U":$GET(^PS(55,+$GET(PSGP),5,+$GET(ON),8)),$GET(ON)["V":$GET(^PS(55,+$GET(PSGP),"IV",+$GET(ON),"DSS")),1:"")
+18 IF PSJORCL
IF $PIECE(PSJORCL,"^",2)
SET PSJCLNK=$$PADECL^PSJPAD50(+$GET(PSJORCL))
if 'PSJCLNK
QUIT
+19 IF '$GET(VAIN(4))
NEW VAIN
DO INP^VADPT
+20 IF '$GET(PSJCLNK)
if '$$PADEWD^PSJPAD50(+$GET(VAIN(4)))
QUIT
+21 SET PADE=$$DRGFLAG^PSJPADSI(PSGP,$GET(ON),,$GET(ON),$GET(PSJNEWOE))
if PADE=0
SET PADE=1
End DoDot:1
+22 NEW PSJDISP
FOR PSJDISP=0:0
SET PSJDISP=$ORDER(@(PSJF_+ON_",1,"_PSJDISP_")"))
if 'PSJDISP
QUIT
Begin DoDot:1
+23 IF $PIECE($GET(^PSDRUG(+$PIECE($GET(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1
SET NF=1
End DoDot:1
+24 ;NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5) ;#373
+25 ;#373
NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1
SET LEN=$SELECT($DATA(PSJEXPT):8,1:10)
+26 ; START NCC REMEDIATION RJS-327
+27 IF $$ISCLOZ^PSJCLOZ(,,DFN,+ON)
Begin DoDot:1
+28 ; REMOVED THE BELOW CODE WITH 398 - PULLING WRONG STOP DATE.
+29 ;D DISPCMP^PSJCLOZ(+$G(ND),.PSSD) S:$G(PSSD) SD=PSSD K PSSD
+30 DO DISPCMP^PSJCLOZ(+$GET(ND),.PSSD)
if '$GET(SD)&$GET(PSSD)
SET SD=PSSD
KILL PSSD
End DoDot:1
+31 ; END NCC REMEDIATION RJS-327
+32 ;F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN)) ;#373
+33 ;#373
FOR X="PSGID","SD"
SET @(X_1)=$SELECT(PSJC["C":"*****",1:$EXTRACT($$ENDTC2^PSGMI(@X),1,LEN))
+34 ;D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) ;#373
+35 ;#373
DO DRGDISP^PSJLMUT1(PSGP,ON,33,27,.DRUGNAME,0)
+36 ;#373
SET RNDTPRT=0
+37 FOR PSJX=0:0
SET PSJX=$ORDER(DRUGNAME(PSJX))
if 'PSJX
QUIT
Begin DoDot:1
+38 IF PSJX=1
Begin DoDot:2
+39 IF PSJFLAG
DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
+40 SET PSJL=$$SETSTR^VALM1($SELECT($EXTRACT(PSJS)="*":$PIECE(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
+41 ;#373
SET PSJL=$$SETSTR^VALM1($SELECT(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,46,3)
+42 ;S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1,2)_$S($L(STAT)=1:" ",1:" ")_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"") ;#373
+43 ;#373
SET PSJL=$$SETSTR^VALM1(PSGID1,PSJL,49,10)
SET PSJL=$$SETSTR^VALM1(SD1,PSJL,60,10)
+44 ;#373
SET PSJL=$$SETSTR^VALM1($EXTRACT(STAT,1,2)_$SELECT($LENGTH(STAT)=1:" ",1:""),PSJL,71,2)
+45 ;S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1,2)_$S($L(STAT)=1:" ",1:" ")
+46 ;I NF!WS!SM!PF!$G(PADE) S PSJL=$$SETSTR^VALM1($S(NF:"NF ",(WS&PADE):"WP ",(PADE&'WS):"PD ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1) ;#373
+47 ;#373
IF NF!WS!SM!PF!$GET(PADE)
SET PSJL=$$SETSTR^VALM1($SELECT(NF:"NF ",(WS&PADE):"WP ",(PADE&'WS):"PD ",WS:"WS ",SM:$EXTRACT("HSM",SM,3),1:""),PSJL,74,3)
if PF
SET PSJL=$$SETSTR^VALM1("*",PSJL,78,1)
End DoDot:2
+48 IF PSJX>1
SET PSJL=""
SET PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,33)
+49 ;#373 - Renewal Date logic added for Unit Dose
IF PSJX=2
DO RNDTDSP
+50 ;I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66) ; #373
+51 DO SETTMP("PSJPRO",PSJL)
IF ($PIECE(NDP2,U,4)="S")
IF STAT="P"
DO CNTRL^VALM10((PSJLN-1),9,9+$LENGTH(PSJL),IOINHI_IOBON,IOINORM,0)
End DoDot:1
+52 ;#373
IF 'RNDTPRT
SET PSJL=""
DO RNDTDSP
if RNDTPRT
DO SETTMP("PSJPRO",PSJL)
+53 IF ND6'=""
NEW X,PSJTXT3
SET X=$$GETSIOPI^PSJBCMA5(DFN,ON)
NEW TXTLN
SET TXTLN=0
FOR
SET TXTLN=$ORDER(^PS(53.45,DUZ,5,TXTLN))
if 'TXTLN!$GET(PSJTXT3)
QUIT
Begin DoDot:1
+54 IF ($ORDER(^PS(53.45,DUZ,5," "),-1)>3)
SET PSJTXT3=1
SET PSJL="Instructions too long. See Order View for full text."
DO PTXT(PSJL,"PSJPRO",10,66)
QUIT
+55 SET PSJL=^PS(53.45,DUZ,5,TXTLN,0)
DO PTXT(PSJL,"PSJPRO",10,66)
End DoDot:1
+56 ;#373
KILL RNDTPRT
+57 KILL ^PS(53.45,DUZ,5)
+58 QUIT
+59 ;
RNDTDSP ; Display Renewal Date - #373
+1 NEW RNDTDSP
SET RNDTDSP=$SELECT($GET(RNDT):$EXTRACT($$ENDTC2^PSGMI(RNDT),1,LEN),1:"")
+2 IF RNDTDSP]""
Begin DoDot:1
+3 SET PSJL=$$SETSTR^VALM1("Renewed:",PSJL,49,8)
+4 SET PSJL=$$SETSTR^VALM1(RNDTDSP,PSJL,58,10)
+5 SET RNDTPRT=1
End DoDot:1
+6 QUIT
+7 ;
PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered.
+1 ;* Input: TXT = Text to display.
+2 ; SUB = First subscript for ^TMP node, ** MUST be PSJ namespace **
+3 ; LM = Begin display of text after LM spaces.
+4 ; RM = Length of display text.
+5 ;
+6 ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.
+7 ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D
+8 SET PSJL=""
SET $PIECE(PSJL," ",LM)=""
+9 FOR X=1:1:$LENGTH(TXT," ")
SET WRD=$PIECE(TXT," ",X)
Begin DoDot:1
+10 ;BHW;PSJ*5*185;check if end of string or just extra space
+11 IF WRD=""
SET PSJL=PSJL_" "
QUIT
+12 IF $LENGTH(PSJL_" "_WRD)'<RM
DO SETTMP(SUB,PSJL)
SET PSJL=""
SET $PIECE(PSJL," ",10)=""
+13 IF $LENGTH(PSJL_" "_WRD)'<RM
SET PSJL=PSJL_" "_$EXTRACT(WRD,1,(RM-10))
DO SETTMP(SUB,PSJL)
SET PSJL=""
SET $PIECE(PSJL," ",10)=""
SET WRD=$EXTRACT(WRD,(RM-9),$LENGTH(WRD))
+14 SET PSJL=PSJL_" "_WRD
End DoDot:1
+15 DO SETTMP(SUB,PSJL)
+16 QUIT
SETTMP(SUB,PSJL) ;
+1 SET ^TMP(SUB,$JOB,PSJLN,0)=PSJL
SET PSJLN=PSJLN+1
+2 QUIT
