PSJLIUTL ;BIR/MV - IV LM utilities modules ;Jul 02, 2018@09:45
;;5.0;INPATIENT MEDICATIONS ;**39,50,58,81,85,110,180,263,267,373,364**;16 DEC 97;Build 47
;
; Reference to ^ORD(101 is supported by DBIA #872.
; Reference to ^PS(55 is supported by DBIA #2191.
; Reference to ES^ORX8 is supported by DBIA #3632.
; Reference to ^PS(52.7 is supported by DBIA 2173.
; Reference to ^PS(52.6 is supported by DBIA 1231.
;
; NFI changes for FR#2@wrtdrg(drgt)
;*364 add Haz meds printing
;
FLDNO(X,COL) ; Display the number next to the field name.
;
; X=Text; COL=Column to start from
;
S:'$D(PSJSTAR) PSJSTAR=""
NEW PSJOLDOT S PSJOLDOT=P("OT") D GTOT^PSIVUTL(P(4))
S X=$S((X="(3)"&(P("OT")="I")):" ",PSJSTAR[X:"*",1:" ")_X
S PSJL=$$SETSTR^VALM1($S(($G(PSJHIS)&(ON'=PSJORD)):"",1:X),PSJL,COL,5)
Q
;
LONG(Y,COL,LEN) ; Display long fields.
;
; Y=Text string; COL=Start prt at this col; LEN=Total lenght per line.
;
N STRLEN,STR S STR="",STRLEN=1
; If string has no blank space.
I $L(Y," ")=1,$L(Y)>LEN D Q
. S LINE=$L(Y)\LEN+$S($L(Y)#LEN:1,1:0)
. F X=1:1:LINE-1 D
. . S PSJL=$$SETSTR^VALM1($E(Y,STRLEN,LEN*X),PSJL,COL,LEN)
. . D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL="",STRLEN=LEN*X+1
. S PSJL=$$SETSTR^VALM1($E(Y,STRLEN,LEN*LINE),PSJL,COL,LEN)
;
F X=1:1:$L(Y," ") D
. I $L(STR)+$L($P(Y," ",X))>LEN D
. . S PSJL=$$SETSTR^VALM1(STR,PSJL,COL,LEN)
. . D SETTMP^PSJLMPRU("PSJI",PSJL) S (STR,PSJL)=""
. S STR=STR_$P(Y," ",X)_" "
S PSJL=$$SETSTR^VALM1(STR,PSJL,COL,LEN)
Q
;
WRTDRG(DRGT) ; Print AD/SOL drugs for "backdoor" view.
NEW DRGX,PSJIVIEN,PSJX,PSJX1
F DRGX=0:0 S DRGX=$O(DRG(DRGT,DRGX)) Q:'DRGX D
. S (PSJIVIEN,X)=$G(DRG(DRGT,DRGX)) I DRGT="SOL",$P($G(^PS(52.7,+X,0)),U,4)]"" S $P(X,U,2)=$P(X,U,2)_" "_$P(^(0),U,4)
. S PSJX1=$S($P(X,U,4)]"":"("_$P(X,U,4)_")",1:$P(X,U,4))
. S PSJL="",PSJX=$S($P(X,U,2)]"":$P(X,U,2)_" "_$P(X,U,3)_" "_PSJX1,1:"*** Undefined ***")
. ;S PSJL="",PSJX=$S($P(X,U,2)]"":$P(X,U,2)_" "_$P(X,U,3)_" "_$P(X,U,4),1:"*** Undefined ***")
. NEW PSJNF D NFIV^PSJDIN($S(DRGT="AD":52.6,1:52.7),+PSJIVIEN,.PSJNF)
. S PSJX=PSJX_PSJNF("NF")
. S PSJL=$$SETSTR^VALM1(PSJX,PSJL,8,72)
. D SETTMP^PSJLMPRU("PSJI",PSJL)
. ;PSJLMX is newed in AD^PSJLIVMD & AD^PSJLIVFD. This var count # of ad/sol so we knows
. ;which line to blink the Requested start/stop dates.
. S PSJLMX=$G(PSJLMX)+1
. ;*364 hazardous handle/dispose functionality added-bg
. I XQY0["PSJI UP" D
.. I DRGT="AD" D
... N P,PSHAZ,PSJNX S PSHAZ=$$HAZ^PSSUTIL($P($G(DRG("AD",DRGX)),U,6),"OI")
... I $P(PSHAZ,"^")=0&($P(PSHAZ,"^",2)=0) Q
... I $P(PSHAZ,"^")=1 S P("HAZH")="<<HAZ Handle>>"
... I $P(PSHAZ,"^",2)=1 S P("HAZD")=" <<HAZ Dispose>>"
... S PSJNX=$G(P("HAZH"))_$G(P("HAZD")) K P("HAZH"),P("HAZD")
... S PSJL=$$SETSTR^VALM1(PSJNX,PSJL,8,73)
... D SETTMP^PSJLMPRU("PSJI",PSJL)
.. I DRGT="SOL" D
... K PSHAZ,P("HAZH"),P("HAZD") N PSHAZ S PSHAZ=$$HAZ^PSSUTIL($P($G(DRG("SOL",1)),U,6),"OI")
... I $P(PSHAZ,"^")=0&($P(PSHAZ,"^",2)=0) Q
... I $P(PSHAZ,"^")=1 S P("HAZH")="<<HAZ Handle>>"
... I $P(PSHAZ,"^",2)=1 S P("HAZD")="<<HAZ Dispose>>"
... S PSJNX=$G(P("HAZH"))_$G(P("HAZD")) K P("HAZH"),P("HAZD")
... S PSJL=$$SETSTR^VALM1(PSJNX,PSJL,8,73)
... D SETTMP^PSJLMPRU("PSJI",PSJL)
Q
;
WTPC ; Write provider comments.
I $G(PSJORD),PSJORD["P" F PSIVX=0:0 S PSIVX=$O(^PS(53.1,+PSJORD,12,PSIVX)) Q:'PSIVX!$D(DUOUT)!$D(DTOUT) S Y=$G(^PS(53.1,+PSJORD,12,PSIVX,0)) D LONG(Y,22,58) D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL=""
Q:$G(PSIVCHG)=1
I $G(PSJORD),PSJORD'["P" F PSIVX=0:0 S PSIVX=$O(^PS(55,DFN,"IV",+PSJORD,5,PSIVX)) Q:'PSIVX!$D(DUOUT)!$D(DTOUT) S Y=$G(^PS(55,DFN,"IV",+PSJORD,5,PSIVX,0)) D LONG(Y,22,58) D SETTMP^PSJLMPRU("PSJI",PSJL) S PSJL=""
Q
;
TYPE() ; IV Type
S X=$$CODES^PSIVUTL(P(4),53.1,53) S X=$S($E(X)="C":"CHEMO",1:X)_$S(P(23)'="":" ("_P(23)_")",1:"")_$S(P(5)=1:" (I)",P(5)=0:"(C)",1:"")
Q X
;
STARTDT() ; Start Date
S X="" I $D(PSIVNUM) S:P("DTYP") X=$S(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$S(P("DTYP")=1:"(12)",$E(P("OT"))="I":"(10)",1:"(8)")
Q $$ENDTC^PSGMI(P(2))
;
STARTDT2() ; Start Date with 4 digit year #373
S X="" I $D(PSIVNUM) S:P("DTYP") X=$S(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$S(P("DTYP")=1:"(12)",$E(P("OT"))="I":"(10)",1:"(8)")
Q $$ENDTC2^PSGMI(P(2))
;
STOPDT() ; Stop Date
S X="" I $D(PSIVNUM) S:P("DTYP") X=$S(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$S(P("DTYP")=1:"(13)",$E(P("OT"))="I":"(11)",1:"(9)")
Q $$ENDTC^PSGMI(P(3))
;
STOPDT2() ; Stop Date with 4 digit year #373
S X="" I $D(PSIVNUM) S:P("DTYP") X=$S(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$S(P("DTYP")=1:"(13)",$E(P("OT"))="I":"(11)",1:"(9)")
Q $$ENDTC2^PSGMI(P(3))
;
PROVIDER() ; Provider
S X="" I $D(PSIVNUM),P("DTYP") S X=$S(PSIVAC="PN":" ",1:"*")_$S(P("DTYP")=1:"(14)",$E(P("OT"))="I":"(12)",1:"(10)") ;I P(17)="P",(+P("CLRK")=+P(6)) S X=""
I $G(P(21))]"",$L($T(ES^ORX8)) N ESIG,ESIG1 S ESIG=P("NAT"),ESIG1=$$ES^ORX8(+P(21)_";1") S:ESIG1=1 ESIG="ES"
S X=$S($P(P(6),U,2)]"":$E($P(P(6),U,2),1,23),1:"*** Undefined") S:$G(ESIG)]"" X=X_" ["_$$LOW^XLFSTR(ESIG)_"]"
Q X
WDTE(Y) ; Format and print date.
I 'Y S Y=""
E X ^DD("DD") S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
Q Y
;
ACTIONS() ;
N DIC,X,Y
S Y=$P($G(^ORD(101,+$G(^ORD(101,DA(1),10,DA,0)),0)),U) I Y="" Q 0
I Y="PSJI LM DISCONTINUE" Q $S(PSGACT["D":1,1:0)
I Y="PSJI LM EDIT" Q $S(PSGACT["E":1,1:0)
I Y="PSJI PC RENEWAL" Q $S(PSGACT["R":1,1:0)
I Y="PSJI PC HOLD" Q $S(PSGACT["H":1,1:0)
I Y="PSJI PC ONCALL" Q $S(PSGACT["O":1,1:0)
I Y="PSJI LM VERIFY" Q $S(PSGACT["V":1,1:0)
I Y="PSJ LM FLAG" Q $S(PSGACT["G":1,1:0)
;PSJ*5*180
I $G(PSJBADD)=1,PSGACT["F" S PSGACT=$TR(PSGACT,"F")
I Y="PSJI LM FINISH" Q $S(PSGACT["F":1,1:0)
I Y="PSJ LM IV PENDING" Q $S(PSGACT["F":1,1:0)
Q 1
;
ACT() ;
NEW Y
S Y=$P($G(^ORD(101,+$G(^ORD(101,DA(1),10,DA,0)),0)),U) I Y="" Q 0
I $G(PSJHIDFG),(Y="PSJ LM NEW ORDER") Q 0
I Y="PSJ LM NEW ORDER FROM PROFILE" Q $S($G(PSIVBR)="D ^PSIVOPT":1,1:0)
Q 1
;
REQDT(ORDER) ;
Q:$G(ORDER)'["P" N ND0,PARENT I '$D(PSGRDTX(+ORDER)) K PSGRDTX
S PSGRDTX=$G(^PS(53.1,+ORDER,2.5)),ND0=$G(^PS(53.1,+ORDER,0)),PARENT=$P($G(^PS(53.1,+ORDER,.2)),"^",8),(PSGRSD,PSGRSDN,PSGRFD,PSGRFDN)=""
Q:'$G(PSGRDTX) I '$P(PSGRDTX,"^",3)&'PARENT Q ; Complex orders (duration OR parent) only?
I $P(ND0,U,9)'["P"!($P(ND0,U,24)="R") K PSGRDTX,PSGRFD,PSGRFDN Q
S $P(PSGRDTX,U,4)=ORDER
S PSGSD=$S($G(P(2)):P(2),1:$G(PSGSD)) I $L(PSGSD)>6 S PSGSD=$$DATE2^PSJUTL2(PSGSD)
S PSGFD=$S($G(P(3)):P(3),1:$G(PSGFD)) I $L(PSGFD)>6 S PSGFD=$$DATE2^PSJUTL2(PSGFD)
I $G(PSGSD),$G(PSGRDTX(+ORDER,"PSGSD")) I (","_PSGRDTX(+ORDER,"PSGSD")_","_PSGRDTX(+ORDER,"PSGRSD")_",")'[(","_PSGSD_",") D
. S PSGRDTX(+ORDER,"PSGSD")=PSGSD
I $G(PSGFD),$G(PSGRDTX(+ORDER,"PSGFD")) I (","_PSGRDTX(+ORDER,"PSGFD")_","_PSGRDTX(+ORDER,"PSGRFD")_",")'[(","_PSGFD_",") D
. S PSGRDTX(+ORDER,"PSGFD")=PSGFD
I $G(PSGSD),'$G(PSGRDTX(+ORDER,"PSGSD")) D
. S PSGRSD=$S($G(PSGRDTX(+ORDER,"PSGRSD")):PSGRDTX(+ORDER,"PSGRSD"),1:$P(PSGRDTX,U)) Q:'PSGRSD
. S A=PSGRSD,PSGRSD=PSGSD,PSGSD=A
. S PSGRDTX(+ORDER,"PSGRSD")=PSGRSD,PSGRDTX(+ORDER,"PSGSD")=PSGSD I $G(P(4))]"",PSGSD]"" S P(2)=PSGSD
. I PARENT,($P($G(PSGSRDTX),"^",3)="") S PSGNESD=PSGSD
I $G(PSGFD),'$G(PSGRDTX(+ORDER,"PSGFD")) D
. S PSGRFD=$S($D(PSGRDTX(+ORDER,"PSGRFD")):PSGRDTX(+ORDER,"PSGRFD"),1:$P(PSGRDTX,U,3)) Q:'PSGRFD
. S A=PSGRFD,PSGRFD=$S($G(PSGFD):PSGFD,1:$G(PSGNEFD)),PSGFD=A
. S PSGRDTX(+ORDER,"PSGRFD")=PSGRFD,(PSGNEFD,PSGRDTX(+ORDER,"PSGFD"))=PSGFD I $G(P(4))]"",PSGFD]"" S P(3)=PSGFD
S PSGSD=$S($G(PSGRDTX(+ORDER,"PSGSD")):PSGRDTX(+ORDER,"PSGSD"),1:$G(PSGSD)) I $G(P(4))]"",$L(PSGSD)>6 S P(2)=$$DATE2^PSJUTL2(PSGSD)
I $G(PSGSD) S PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC2^PSGMI(PSGSD) ;#373 ENDTC2 call replaces ENDTC call
S PSGRSD=$S($G(PSGRDTX(+ORDER,"PSGRSD")):PSGRDTX(+ORDER,"PSGRSD"),1:$G(PSGRSD))
I $G(PSGRSD) S PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
I $G(PSGRDTX(+ORDER,"PSGFD")),$G(PSGSD) I PSGSD>PSGRDTX(+ORDER,"PSGFD") N DUR S DUR=$P($G(PSGRDTX),U,2) D
. N DURMIN S DURMIN=$$DURMIN^PSJLIVMD(DUR) S (PSGFD,PSGRDTX(+ORDER,"PSGFD"))=$$FMADD^XLFDT(PSGSD,,,$S(DURMIN:DURMIN,1:1440))
S PSGFD=$S($G(PSGRDTX(+ORDER,"PSGFD")):PSGRDTX(+ORDER,"PSGFD"),1:$G(PSGFD)) D
. I PSGFD<PSGSD,$G(PSGFD),ORDER'["V" N PSGST I $G(DFN) S PSGST=$S(PSGORD["P":$P(^PS(53.1,+PSGORD,0),"^",7),1:$P(^PS(55,DFN,5,+PSGORD,0),"^",7)) D
.. D ENFD^PSGNE3(PSGSD) I PSGNEFD>PSGSD S PSGFD=PSGNEFD
. I PSGFD<PSGSD,$G(PSGFD),ORDER["V" D ENSTOP^PSIVCAL I P(3)>P(2) S PSGFD=P(3)
. I $G(P(4))]"",$L(PSGFD)>6 S P(3)=$$DATE2^PSJUTL2(PSGFD)
I $G(PSGFD) S PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC2^PSGMI(PSGFD) ;#373 ENDTC2 call replaces ENDTC call
S PSGRFD=$S($G(PSGRDTX(+ORDER,"PSGRFD")):PSGRDTX(+ORDER,"PSGRFD"),1:$G(PSGRFD))
I $G(PSGRFD) S PSGRFDN=$$ENDTC^PSGMI(PSGRFD)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJLIUTL 8875 printed Oct 16, 2024@18:08:09 Page 2
PSJLIUTL ;BIR/MV - IV LM utilities modules ;Jul 02, 2018@09:45
+1 ;;5.0;INPATIENT MEDICATIONS ;**39,50,58,81,85,110,180,263,267,373,364**;16 DEC 97;Build 47
+2 ;
+3 ; Reference to ^ORD(101 is supported by DBIA #872.
+4 ; Reference to ^PS(55 is supported by DBIA #2191.
+5 ; Reference to ES^ORX8 is supported by DBIA #3632.
+6 ; Reference to ^PS(52.7 is supported by DBIA 2173.
+7 ; Reference to ^PS(52.6 is supported by DBIA 1231.
+8 ;
+9 ; NFI changes for FR#2@wrtdrg(drgt)
+10 ;*364 add Haz meds printing
+11 ;
FLDNO(X,COL) ; Display the number next to the field name.
+1 ;
+2 ; X=Text; COL=Column to start from
+3 ;
+4 if '$DATA(PSJSTAR)
SET PSJSTAR=""
+5 NEW PSJOLDOT
SET PSJOLDOT=P("OT")
DO GTOT^PSIVUTL(P(4))
+6 SET X=$SELECT((X="(3)"&(P("OT")="I")):" ",PSJSTAR[X:"*",1:" ")_X
+7 SET PSJL=$$SETSTR^VALM1($SELECT(($GET(PSJHIS)&(ON'=PSJORD)):"",1:X),PSJL,COL,5)
+8 QUIT
+9 ;
LONG(Y,COL,LEN) ; Display long fields.
+1 ;
+2 ; Y=Text string; COL=Start prt at this col; LEN=Total lenght per line.
+3 ;
+4 NEW STRLEN,STR
SET STR=""
SET STRLEN=1
+5 ; If string has no blank space.
+6 IF $LENGTH(Y," ")=1
IF $LENGTH(Y)>LEN
Begin DoDot:1
+7 SET LINE=$LENGTH(Y)\LEN+$SELECT($LENGTH(Y)#LEN:1,1:0)
+8 FOR X=1:1:LINE-1
Begin DoDot:2
+9 SET PSJL=$$SETSTR^VALM1($EXTRACT(Y,STRLEN,LEN*X),PSJL,COL,LEN)
+10 DO SETTMP^PSJLMPRU("PSJI",PSJL)
SET PSJL=""
SET STRLEN=LEN*X+1
End DoDot:2
+11 SET PSJL=$$SETSTR^VALM1($EXTRACT(Y,STRLEN,LEN*LINE),PSJL,COL,LEN)
End DoDot:1
QUIT
+12 ;
+13 FOR X=1:1:$LENGTH(Y," ")
Begin DoDot:1
+14 IF $LENGTH(STR)+$LENGTH($PIECE(Y," ",X))>LEN
Begin DoDot:2
+15 SET PSJL=$$SETSTR^VALM1(STR,PSJL,COL,LEN)
+16 DO SETTMP^PSJLMPRU("PSJI",PSJL)
SET (STR,PSJL)=""
End DoDot:2
+17 SET STR=STR_$PIECE(Y," ",X)_" "
End DoDot:1
+18 SET PSJL=$$SETSTR^VALM1(STR,PSJL,COL,LEN)
+19 QUIT
+20 ;
WRTDRG(DRGT) ; Print AD/SOL drugs for "backdoor" view.
+1 NEW DRGX,PSJIVIEN,PSJX,PSJX1
+2 FOR DRGX=0:0
SET DRGX=$ORDER(DRG(DRGT,DRGX))
if 'DRGX
QUIT
Begin DoDot:1
+3 SET (PSJIVIEN,X)=$GET(DRG(DRGT,DRGX))
IF DRGT="SOL"
IF $PIECE($GET(^PS(52.7,+X,0)),U,4)]""
SET $PIECE(X,U,2)=$PIECE(X,U,2)_" "_$PIECE(^(0),U,4)
+4 SET PSJX1=$SELECT($PIECE(X,U,4)]"":"("_$PIECE(X,U,4)_")",1:$PIECE(X,U,4))
+5 SET PSJL=""
SET PSJX=$SELECT($PIECE(X,U,2)]"":$PIECE(X,U,2)_" "_$PIECE(X,U,3)_" "_PSJX1,1:"*** Undefined ***")
+6 ;S PSJL="",PSJX=$S($P(X,U,2)]"":$P(X,U,2)_" "_$P(X,U,3)_" "_$P(X,U,4),1:"*** Undefined ***")
+7 NEW PSJNF
DO NFIV^PSJDIN($SELECT(DRGT="AD":52.6,1:52.7),+PSJIVIEN,.PSJNF)
+8 SET PSJX=PSJX_PSJNF("NF")
+9 SET PSJL=$$SETSTR^VALM1(PSJX,PSJL,8,72)
+10 DO SETTMP^PSJLMPRU("PSJI",PSJL)
+11 ;PSJLMX is newed in AD^PSJLIVMD & AD^PSJLIVFD. This var count # of ad/sol so we knows
+12 ;which line to blink the Requested start/stop dates.
+13 SET PSJLMX=$GET(PSJLMX)+1
+14 ;*364 hazardous handle/dispose functionality added-bg
+15 IF XQY0["PSJI UP"
Begin DoDot:2
+16 IF DRGT="AD"
Begin DoDot:3
+17 NEW P,PSHAZ,PSJNX
SET PSHAZ=$$HAZ^PSSUTIL($PIECE($GET(DRG("AD",DRGX)),U,6),"OI")
+18 IF $PIECE(PSHAZ,"^")=0&($PIECE(PSHAZ,"^",2)=0)
QUIT
+19 IF $PIECE(PSHAZ,"^")=1
SET P("HAZH")="<<HAZ Handle>>"
+20 IF $PIECE(PSHAZ,"^",2)=1
SET P("HAZD")=" <<HAZ Dispose>>"
+21 SET PSJNX=$GET(P("HAZH"))_$GET(P("HAZD"))
KILL P("HAZH"),P("HAZD")
+22 SET PSJL=$$SETSTR^VALM1(PSJNX,PSJL,8,73)
+23 DO SETTMP^PSJLMPRU("PSJI",PSJL)
End DoDot:3
+24 IF DRGT="SOL"
Begin DoDot:3
+25 KILL PSHAZ,P("HAZH"),P("HAZD")
NEW PSHAZ
SET PSHAZ=$$HAZ^PSSUTIL($PIECE($GET(DRG("SOL",1)),U,6),"OI")
+26 IF $PIECE(PSHAZ,"^")=0&($PIECE(PSHAZ,"^",2)=0)
QUIT
+27 IF $PIECE(PSHAZ,"^")=1
SET P("HAZH")="<<HAZ Handle>>"
+28 IF $PIECE(PSHAZ,"^",2)=1
SET P("HAZD")="<<HAZ Dispose>>"
+29 SET PSJNX=$GET(P("HAZH"))_$GET(P("HAZD"))
KILL P("HAZH"),P("HAZD")
+30 SET PSJL=$$SETSTR^VALM1(PSJNX,PSJL,8,73)
+31 DO SETTMP^PSJLMPRU("PSJI",PSJL)
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
WTPC ; Write provider comments.
+1 IF $GET(PSJORD)
IF PSJORD["P"
FOR PSIVX=0:0
SET PSIVX=$ORDER(^PS(53.1,+PSJORD,12,PSIVX))
if 'PSIVX!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
SET Y=$GET(^PS(53.1,+PSJORD,12,PSIVX,0))
DO LONG(Y,22,58)
DO SETTMP^PSJLMPRU("PSJI",PSJL)
SET PSJL=""
+2 if $GET(PSIVCHG)=1
QUIT
+3 IF $GET(PSJORD)
IF PSJORD'["P"
FOR PSIVX=0:0
SET PSIVX=$ORDER(^PS(55,DFN,"IV",+PSJORD,5,PSIVX))
if 'PSIVX!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
SET Y=$GET(^PS(55,DFN,"IV",+PSJORD,5,PSIVX,0))
DO LONG(Y,22,58)
DO SETTMP^PSJLMPRU("PSJI",PSJL)
SET PSJL=""
+4 QUIT
+5 ;
TYPE() ; IV Type
+1 SET X=$$CODES^PSIVUTL(P(4),53.1,53)
SET X=$SELECT($EXTRACT(X)="C":"CHEMO",1:X)_$SELECT(P(23)'="":" ("_P(23)_")",1:"")_$SELECT(P(5)=1:" (I)",P(5)=0:"(C)",1:"")
+2 QUIT X
+3 ;
STARTDT() ; Start Date
+1 SET X=""
IF $DATA(PSIVNUM)
if P("DTYP")
SET X=$SELECT(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$SELECT(P("DTYP")=1:"(12)",$EXTRACT(P("OT"))="I":"(10)",1:"(8)")
+2 QUIT $$ENDTC^PSGMI(P(2))
+3 ;
STARTDT2() ; Start Date with 4 digit year #373
+1 SET X=""
IF $DATA(PSIVNUM)
if P("DTYP")
SET X=$SELECT(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$SELECT(P("DTYP")=1:"(12)",$EXTRACT(P("OT"))="I":"(10)",1:"(8)")
+2 QUIT $$ENDTC2^PSGMI(P(2))
+3 ;
STOPDT() ; Stop Date
+1 SET X=""
IF $DATA(PSIVNUM)
if P("DTYP")
SET X=$SELECT(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$SELECT(P("DTYP")=1:"(13)",$EXTRACT(P("OT"))="I":"(11)",1:"(9)")
+2 QUIT $$ENDTC^PSGMI(P(3))
+3 ;
STOPDT2() ; Stop Date with 4 digit year #373
+1 SET X=""
IF $DATA(PSIVNUM)
if P("DTYP")
SET X=$SELECT(P(17)="P"!(PSIVAC="PN"):" ",1:"*")_$SELECT(P("DTYP")=1:"(13)",$EXTRACT(P("OT"))="I":"(11)",1:"(9)")
+2 QUIT $$ENDTC2^PSGMI(P(3))
+3 ;
PROVIDER() ; Provider
+1 ;I P(17)="P",(+P("CLRK")=+P(6)) S X=""
SET X=""
IF $DATA(PSIVNUM)
IF P("DTYP")
SET X=$SELECT(PSIVAC="PN":" ",1:"*")_$SELECT(P("DTYP")=1:"(14)",$EXTRACT(P("OT"))="I":"(12)",1:"(10)")
+2 IF $GET(P(21))]""
IF $LENGTH($TEXT(ES^ORX8))
NEW ESIG,ESIG1
SET ESIG=P("NAT")
SET ESIG1=$$ES^ORX8(+P(21)_";1")
if ESIG1=1
SET ESIG="ES"
+3 SET X=$SELECT($PIECE(P(6),U,2)]"":$EXTRACT($PIECE(P(6),U,2),1,23),1:"*** Undefined")
if $GET(ESIG)]""
SET X=X_" ["_$$LOW^XLFSTR(ESIG)_"]"
+4 QUIT X
WDTE(Y) ; Format and print date.
+1 IF 'Y
SET Y=""
+2 IF '$TEST
XECUTE ^DD("DD")
SET Y=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)
+3 QUIT Y
+4 ;
ACTIONS() ;
+1 NEW DIC,X,Y
+2 SET Y=$PIECE($GET(^ORD(101,+$GET(^ORD(101,DA(1),10,DA,0)),0)),U)
IF Y=""
QUIT 0
+3 IF Y="PSJI LM DISCONTINUE"
QUIT $SELECT(PSGACT["D":1,1:0)
+4 IF Y="PSJI LM EDIT"
QUIT $SELECT(PSGACT["E":1,1:0)
+5 IF Y="PSJI PC RENEWAL"
QUIT $SELECT(PSGACT["R":1,1:0)
+6 IF Y="PSJI PC HOLD"
QUIT $SELECT(PSGACT["H":1,1:0)
+7 IF Y="PSJI PC ONCALL"
QUIT $SELECT(PSGACT["O":1,1:0)
+8 IF Y="PSJI LM VERIFY"
QUIT $SELECT(PSGACT["V":1,1:0)
+9 IF Y="PSJ LM FLAG"
QUIT $SELECT(PSGACT["G":1,1:0)
+10 ;PSJ*5*180
+11 IF $GET(PSJBADD)=1
IF PSGACT["F"
SET PSGACT=$TRANSLATE(PSGACT,"F")
+12 IF Y="PSJI LM FINISH"
QUIT $SELECT(PSGACT["F":1,1:0)
+13 IF Y="PSJ LM IV PENDING"
QUIT $SELECT(PSGACT["F":1,1:0)
+14 QUIT 1
+15 ;
ACT() ;
+1 NEW Y
+2 SET Y=$PIECE($GET(^ORD(101,+$GET(^ORD(101,DA(1),10,DA,0)),0)),U)
IF Y=""
QUIT 0
+3 IF $GET(PSJHIDFG)
IF (Y="PSJ LM NEW ORDER")
QUIT 0
+4 IF Y="PSJ LM NEW ORDER FROM PROFILE"
QUIT $SELECT($GET(PSIVBR)="D ^PSIVOPT":1,1:0)
+5 QUIT 1
+6 ;
REQDT(ORDER) ;
+1 if $GET(ORDER)'["P"
QUIT
NEW ND0,PARENT
IF '$DATA(PSGRDTX(+ORDER))
KILL PSGRDTX
+2 SET PSGRDTX=$GET(^PS(53.1,+ORDER,2.5))
SET ND0=$GET(^PS(53.1,+ORDER,0))
SET PARENT=$PIECE($GET(^PS(53.1,+ORDER,.2)),"^",8)
SET (PSGRSD,PSGRSDN,PSGRFD,PSGRFDN)=""
+3 ; Complex orders (duration OR parent) only?
if '$GET(PSGRDTX)
QUIT
IF '$PIECE(PSGRDTX,"^",3)&'PARENT
QUIT
+4 IF $PIECE(ND0,U,9)'["P"!($PIECE(ND0,U,24)="R")
KILL PSGRDTX,PSGRFD,PSGRFDN
QUIT
+5 SET $PIECE(PSGRDTX,U,4)=ORDER
+6 SET PSGSD=$SELECT($GET(P(2)):P(2),1:$GET(PSGSD))
IF $LENGTH(PSGSD)>6
SET PSGSD=$$DATE2^PSJUTL2(PSGSD)
+7 SET PSGFD=$SELECT($GET(P(3)):P(3),1:$GET(PSGFD))
IF $LENGTH(PSGFD)>6
SET PSGFD=$$DATE2^PSJUTL2(PSGFD)
+8 IF $GET(PSGSD)
IF $GET(PSGRDTX(+ORDER,"PSGSD"))
IF (","_PSGRDTX(+ORDER,"PSGSD")_","_PSGRDTX(+ORDER,"PSGRSD")_",")'[(","_PSGSD_",")
Begin DoDot:1
+9 SET PSGRDTX(+ORDER,"PSGSD")=PSGSD
End DoDot:1
+10 IF $GET(PSGFD)
IF $GET(PSGRDTX(+ORDER,"PSGFD"))
IF (","_PSGRDTX(+ORDER,"PSGFD")_","_PSGRDTX(+ORDER,"PSGRFD")_",")'[(","_PSGFD_",")
Begin DoDot:1
+11 SET PSGRDTX(+ORDER,"PSGFD")=PSGFD
End DoDot:1
+12 IF $GET(PSGSD)
IF '$GET(PSGRDTX(+ORDER,"PSGSD"))
Begin DoDot:1
+13 SET PSGRSD=$SELECT($GET(PSGRDTX(+ORDER,"PSGRSD")):PSGRDTX(+ORDER,"PSGRSD"),1:$PIECE(PSGRDTX,U))
if 'PSGRSD
QUIT
+14 SET A=PSGRSD
SET PSGRSD=PSGSD
SET PSGSD=A
+15 SET PSGRDTX(+ORDER,"PSGRSD")=PSGRSD
SET PSGRDTX(+ORDER,"PSGSD")=PSGSD
IF $GET(P(4))]""
IF PSGSD]""
SET P(2)=PSGSD
+16 IF PARENT
IF ($PIECE($GET(PSGSRDTX),"^",3)="")
SET PSGNESD=PSGSD
End DoDot:1
+17 IF $GET(PSGFD)
IF '$GET(PSGRDTX(+ORDER,"PSGFD"))
Begin DoDot:1
+18 SET PSGRFD=$SELECT($DATA(PSGRDTX(+ORDER,"PSGRFD")):PSGRDTX(+ORDER,"PSGRFD"),1:$PIECE(PSGRDTX,U,3))
if 'PSGRFD
QUIT
+19 SET A=PSGRFD
SET PSGRFD=$SELECT($GET(PSGFD):PSGFD,1:$GET(PSGNEFD))
SET PSGFD=A
+20 SET PSGRDTX(+ORDER,"PSGRFD")=PSGRFD
SET (PSGNEFD,PSGRDTX(+ORDER,"PSGFD"))=PSGFD
IF $GET(P(4))]""
IF PSGFD]""
SET P(3)=PSGFD
End DoDot:1
+21 SET PSGSD=$SELECT($GET(PSGRDTX(+ORDER,"PSGSD")):PSGRDTX(+ORDER,"PSGSD"),1:$GET(PSGSD))
IF $GET(P(4))]""
IF $LENGTH(PSGSD)>6
SET P(2)=$$DATE2^PSJUTL2(PSGSD)
+22 ;#373 ENDTC2 call replaces ENDTC call
IF $GET(PSGSD)
SET PSGSDN=$$ENDD^PSGMI(PSGSD)_U_$$ENDTC2^PSGMI(PSGSD)
+23 SET PSGRSD=$SELECT($GET(PSGRDTX(+ORDER,"PSGRSD")):PSGRDTX(+ORDER,"PSGRSD"),1:$GET(PSGRSD))
+24 IF $GET(PSGRSD)
SET PSGRSDN=$$ENDTC^PSGMI(PSGRSD)
+25 IF $GET(PSGRDTX(+ORDER,"PSGFD"))
IF $GET(PSGSD)
IF PSGSD>PSGRDTX(+ORDER,"PSGFD")
NEW DUR
SET DUR=$PIECE($GET(PSGRDTX),U,2)
Begin DoDot:1
+26 NEW DURMIN
SET DURMIN=$$DURMIN^PSJLIVMD(DUR)
SET (PSGFD,PSGRDTX(+ORDER,"PSGFD"))=$$FMADD^XLFDT(PSGSD,,,$SELECT(DURMIN:DURMIN,1:1440))
End DoDot:1
+27 SET PSGFD=$SELECT($GET(PSGRDTX(+ORDER,"PSGFD")):PSGRDTX(+ORDER,"PSGFD"),1:$GET(PSGFD))
Begin DoDot:1
+28 IF PSGFD<PSGSD
IF $GET(PSGFD)
IF ORDER'["V"
NEW PSGST
IF $GET(DFN)
SET PSGST=$SELECT(PSGORD["P":$PIECE(^PS(53.1,+PSGORD,0),"^",7),1:$PIECE(^PS(55,DFN,5,+PSGORD,0),"^",7))
Begin DoDot:2
+29 DO ENFD^PSGNE3(PSGSD)
IF PSGNEFD>PSGSD
SET PSGFD=PSGNEFD
End DoDot:2
+30 IF PSGFD<PSGSD
IF $GET(PSGFD)
IF ORDER["V"
DO ENSTOP^PSIVCAL
IF P(3)>P(2)
SET PSGFD=P(3)
+31 IF $GET(P(4))]""
IF $LENGTH(PSGFD)>6
SET P(3)=$$DATE2^PSJUTL2(PSGFD)
End DoDot:1
+32 ;#373 ENDTC2 call replaces ENDTC call
IF $GET(PSGFD)
SET PSGFDN=$$ENDD^PSGMI(PSGFD)_U_$$ENDTC2^PSGMI(PSGFD)
+33 SET PSGRFD=$SELECT($GET(PSGRDTX(+ORDER,"PSGRFD")):PSGRDTX(+ORDER,"PSGRFD"),1:$GET(PSGRFD))
+34 IF $GET(PSGRFD)
SET PSGRFDN=$$ENDTC^PSGMI(PSGRFD)
+35 QUIT
