Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSJLMPRU

PSJLMPRU.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^PSDRUG is supported by DBIA 2192.
  1. ; Reference to ^PS(55 is supported by DBIA 2191.
  1. ; Reference to $$GET^XPAR is supported by DBIA 2263
  1. ;
  1. PUD(DFN,ON,PSJF,DN) ; Setup LM profile view for UD
  1. N PSJFLAG,PSJV,PADE
  1. ; Naked references on the two lines below refer to full reference ^PS(55,DFN,5,+ON in PSJF using indirection.
  1. 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)
  1. S ND14=$G(@(PSJF_+ON_",14,0)")),RNDT="" I $P(ND14,"^",3) S ND14=$G(^($P(ND14,"^",3),0)),RNDT=$P(ND14,"^")
  1. I ("AO"[PSJC)!(PSJC="DF") D
  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)
  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)
  1. .S PSJL=$$SETSTR^VALM1(PSJV,PSJL,6,3)
  1. 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,"^")
  1. I STAT="A",$P(ND,U,27)="R" S STAT="R"
  1. S NF="",WS=$S(PSJPWD:$$WS^PSJO(PSJPWD,PSGP,PSJF,+ON),1:0)
  1. I $D(PSJCLIN) S WS=0 ; PSJ*5*323
  1. ; PSJ*5*317 - If PSJ PADE OE BALANCES parameter is YES, PADE balances should display as identifier
  1. S PADE=0 I $$GET^XPAR("SYS","PSJ PADE OE BALANCES") D
  1. .N PSJORCL,PSJCLNK
  1. .; If clinic order, quit if clinic location is not linked to PADE
  1. .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:"")
  1. .I PSJORCL,$P(PSJORCL,"^",2) S PSJCLNK=$$PADECL^PSJPAD50(+$G(PSJORCL)) Q:'PSJCLNK
  1. .I '$G(VAIN(4)) N VAIN D INP^VADPT
  1. .I '$G(PSJCLNK) Q:'$$PADEWD^PSJPAD50(+$G(VAIN(4)))
  1. .S PADE=$$DRGFLAG^PSJPADSI(PSGP,$G(ON),,$G(ON),$G(PSJNEWOE)) S:PADE=0 PADE=1
  1. N PSJDISP F PSJDISP=0:0 S PSJDISP=$O(@(PSJF_+ON_",1,"_PSJDISP_")")) Q:'PSJDISP D
  1. .I $P($G(^PSDRUG(+$P($G(@(PSJF_+ON_",1,"_PSJDISP_",0)")),"^"),0)),"^",9)=1 S NF=1
  1. ;NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:5) ;#373
  1. NEW DRUGNAME,PSGID1,SD1,LEN,PSGID1,SD1 S LEN=$S($D(PSJEXPT):8,1:10) ;#373
  1. ; START NCC REMEDIATION RJS-327
  1. I $$ISCLOZ^PSJCLOZ(,,DFN,+ON) D
  1. .; REMOVED THE BELOW CODE WITH 398 - PULLING WRONG STOP DATE.
  1. .;D DISPCMP^PSJCLOZ(+$G(ND),.PSSD) S:$G(PSSD) SD=PSSD K PSSD
  1. .D DISPCMP^PSJCLOZ(+$G(ND),.PSSD) S:'$G(SD)&$G(PSSD) SD=PSSD K PSSD
  1. ; END NCC REMEDIATION RJS-327
  1. ;F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC^PSGMI(@X),1,LEN)) ;#373
  1. F X="PSGID","SD" S @(X_1)=$S(PSJC["C":"*****",1:$E($$ENDTC2^PSGMI(@X),1,LEN)) ;#373
  1. ;D DRGDISP^PSJLMUT1(PSGP,ON,39,54,.DRUGNAME,0) ;#373
  1. D DRGDISP^PSJLMUT1(PSGP,ON,33,27,.DRUGNAME,0) ;#373
  1. S RNDTPRT=0 ;#373
  1. F PSJX=0:0 S PSJX=$O(DRUGNAME(PSJX)) Q:'PSJX D
  1. .I PSJX=1 D
  1. ..I PSJFLAG D CNTRL^VALM10(PSJLN,1,4,IORVON,IORVOFF,0)
  1. ..S PSJL=$$SETSTR^VALM1($S($E(PSJS)="*":$P(PSJS,"^"),1:DRUGNAME(PSJX)),PSJL,9,39)
  1. ..S PSJL=$$SETSTR^VALM1($S(PSJC["C":"?",PSJSCHT'="z":PSJSCHT,1:"?"),PSJL,46,3) ;#373
  1. ..;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
  1. ..S PSJL=$$SETSTR^VALM1(PSGID1,PSJL,49,10),PSJL=$$SETSTR^VALM1(SD1,PSJL,60,10) ;#373
  1. ..S PSJL=$$SETSTR^VALM1($E(STAT,1,2)_$S($L(STAT)=1:" ",1:""),PSJL,71,2) ;#373
  1. ..;S PSJL=PSJL_PSGID1_" "_SD1_" "_$E(STAT,1,2)_$S($L(STAT)=1:" ",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
  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,74,3) S:PF PSJL=$$SETSTR^VALM1("*",PSJL,78,1) ;#373
  1. . I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,33)
  1. . I PSJX=2 D RNDTDSP ;#373 - Renewal Date logic added for Unit Dose
  1. . ;I PSJX>1 S PSJL="",PSJL=$$SETSTR^VALM1(DRUGNAME(PSJX),PSJL,11,66) ; #373
  1. . 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)
  1. I 'RNDTPRT S PSJL="" D RNDTDSP D:RNDTPRT SETTMP("PSJPRO",PSJL) ;#373
  1. 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
  1. .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
  1. .S PSJL=^PS(53.45,DUZ,5,TXTLN,0) D PTXT(PSJL,"PSJPRO",10,66)
  1. K RNDTPRT ;#373
  1. K ^PS(53.45,DUZ,5)
  1. Q
  1. ;
  1. RNDTDSP ; Display Renewal Date - #373
  1. NEW RNDTDSP S RNDTDSP=$S($G(RNDT):$E($$ENDTC2^PSGMI(RNDT),1,LEN),1:"")
  1. I RNDTDSP]"" D
  1. . S PSJL=$$SETSTR^VALM1("Renewed:",PSJL,49,8)
  1. . S PSJL=$$SETSTR^VALM1(RNDTDSP,PSJL,58,10)
  1. . S RNDTPRT=1
  1. Q
  1. ;
  1. PTXT(TXT,SUB,LM,RM) ; Display Instructions/dosage ordered.
  1. ;* Input: TXT = Text to display.
  1. ; SUB = First subscript for ^TMP node, ** MUST be PSJ namespace **
  1. ; LM = Begin display of text after LM spaces.
  1. ; RM = Length of display text.
  1. ;
  1. ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.
  1. ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD="" D
  1. S PSJL="",$P(PSJL," ",LM)=""
  1. F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D
  1. .;BHW;PSJ*5*185;check if end of string or just extra space
  1. .I WRD="" S PSJL=PSJL_" " Q
  1. .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
  1. .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))
  1. .S PSJL=PSJL_" "_WRD
  1. D SETTMP(SUB,PSJL)
  1. Q
  1. SETTMP(SUB,PSJL) ;
  1. S ^TMP(SUB,$J,PSJLN,0)=PSJL,PSJLN=PSJLN+1
  1. Q