- PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
- ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6
- ;
- ; Reference to ^PSDRUG is supported by DBIA 2192.
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ;
- PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
- N PSJFLAG,PSJV
- ; 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 D
- .;S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
- .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 X=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
- .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)
- ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3)
- ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")
- S RTE=$P(ND,"^",3),SM=$S('$P(ND,"^",5):0,$P(ND,"^",6):1,1:2),STAT=$S($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=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
- S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
- 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)
- F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN))
- D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
- 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,50,3)
- ..S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1)_" "_$S($G(RNDT):$E($$ENDTC^PSGMI(RNDT),1,LEN),1:"")
- ..I NF!WS!SM!PF S PSJL=$$SETSTR^VALM1($S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:""),PSJL,69,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,79,1)
- . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66)
- . 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)
- D:$P(ND6,"^")]"" PTXT($P(ND6,"^"),"PSJPRO",10,66)
- 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
- PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6
- +2 ;
- +3 ; Reference to ^PSDRUG is supported by DBIA 2192.
- +4 ; Reference to ^PS(55 is supported by DBIA 2191.
- +5 ;
- PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
- +1 NEW PSJFLAG,PSJV
- +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
- Begin DoDot:1
- +6 ;S V='$P(ND4,"^",UDU),PSJL=$$SETSTR^VALM1($S(ND4="":" ",$P(ND4,"^",12):"D",$P(ND4,"^",18)&($P(ND4,"^",19)!V):"H",$P(ND4,"^",22)&($P(ND4,"^",23)!V):"H",$P(ND4,"^",15)&($P(ND4,"^",16)!V):"R",1:" "),PSJL,5,1)
- +7 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)
- +8 ;S X=$S(+PSJSYSU=1&V:1,+PSJSYSU=3&V:1,1:0)
- +9 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)
- +10 SET PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
- End DoDot:1
- +11 ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")_$S($P(ND,U,4)="I":"",PSJSYSU:"->",1:""),PSJL,6,3)
- +12 ;I $S(PSJC["C":0,1:PSJC["B") S PSJL=$$SETSTR^VALM1($S($P(ND4,"^",12):"D",1:" ")
- +13 SET RTE=$PIECE(ND,"^",3)
- SET SM=$SELECT('$PIECE(ND,"^",5):0,$PIECE(ND,"^",6):1,1:2)
- SET STAT=$SELECT($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,"^")
- +14 IF STAT="A"
- IF $PIECE(ND,U,27)="R"
- SET STAT="R"
- +15 ;S NF=$P(DN,"^",3),WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
- +16 SET NF=""
- SET WS=$SELECT(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
- +17 NEW PSJDISP
- FOR PSJDISP=0:0
- SET PSJDISP=$ORDER(@(PSJF_+ON_",1,"_PSJDISP_")"))
- IF 'PSJDISP
- QUIT
- Begin DoDot:1
- +18 IF $PIECE($GET(^PSDRUG(+$PIECE($GET(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1
- SET NF=1
- End DoDot:1
- +19 NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1
- SET LEN=$SELECT($DATA(PSJEXPT):8,1:5)
- +20 FOR X="PSGID","SD"
- SET @(X_1)=$SELECT(PSJC["C":"*****",1:$EXTRACT($$ENDTC^PSGMI(@X),1,LEN))
- +21 DO DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0)
- +22 FOR PSJX=0:0
- SET PSJX=$ORDER(DRUGNAME(PSJX))
- IF 'PSJX
- QUIT
- Begin DoDot:1
- +23 IF PSJX=1
- Begin DoDot:2
- +24 IF PSJFLAG
- DO CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
- +25 SET PSJL=$$SETSTR^VALM1($SELECT($EXTRACT(PSJS)="*":$PIECE(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
- +26 SET PSJL=$$SETSTR^VALM1($SELECT(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,50,3)
- +27 SET PSJL=PSJL_PSGID1_" "_SD1_" "_$EXTRACT(STAT,1)_" "_$SELECT($GET(RNDT):$EXTRACT($$ENDTC^PSGMI(RNDT),1,LEN),1:"")
- +28 IF NF!WS!SM!PF
- SET PSJL=$$SETSTR^VALM1($SELECT(NF:"NF ",WS:"WS ",SM:$EXTRACT("HSM",SM,3),1:""),PSJL,69,3)
- IF PF
- SET PSJL=$$SETSTR^VALM1("*",PSJL,79,1)
- End DoDot:2
- +29 IF PSJX>1
- SET PSJL=""
- SET PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66)
- +30 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
- +31 IF $PIECE(ND6,"^")]""
- DO PTXT($PIECE(ND6,"^"),"PSJPRO",10,66)
- +32 QUIT
- +33 ;
- 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
