PSGOU ;BIR/CML3,MV-PROFILE UTILITIES ;19 SEP 96 / 3:59 PM
;;5.0; INPATIENT MEDICATIONS ;**34,110**;16 DEC 97
;
; Reference to ^PS(51.1 is supported by DBIA# 2177
; Reference to ^PS(55 is supported by DBIA# 2191.
;
ECHK ;
D NOW^%DTC N PSGDT S PSGDT=% ;***Store PSGDT with seconds.
S C="A",ON=O_"U" G:SD>PSGDT DS S ND=$G(^PS(55,PSGP,5,O,0)) G:$S($P(ND,"^",9)="":1,1:"DE"'[$P(ND,"^",9)) DS S ND4=$G(^(4))
I ST'="O",SD'<PSGODT,$P(ND,"^",9)="E",$P(ND4,"^",16) G DS
I ST="O",$P(ND,"^",9)'["D",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16)) G DS
Q:PSGOL="S" S C="O"
;
DS ;
NEW DRUGNAME D DRGDISP^PSJLMUT1(PSGP,+O_"U",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
;
SET ;
I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
S ^TMP("PSG",$J,C,ST,DRG_"^"_ON)=$G(NF)
Q
;
ENS F S=0:0 R !!,"Sort by DATE or MEDICATION: M// ",PSGOS:DTIME D SCHK Q:CHK
Q
;
ENL ;
F W !!,"SHORT, LONG, or NO Profile? ",$S('$D(PSJPDD):"SHORT",'PSJPDD:"SHORT",1:"LONG"),"// " R PSGOL:DTIME W:'$T $C(7) S:'$T PSGOL="^" Q:PSGOL="^" D LCHK Q:"^SLN"[PSGOL&($L(PSGOL)=1)
Q
;
SCHK ;
I '$T!(PSGOS["^") S PSGOS="^",CHK=1 Q
S CHK=0 D:PSGOS["?" SM Q:PSGOS["?" I PSGOS="" S PSGOS="M",CHK=1 W "MEDICATION" Q
F X="DATE","MEDICATION" I $P(X,PSGOS)="" W $P(X,PSGOS,2) S PSGOS=$E(PSGOS),CHK=1 Q
W:'CHK $C(7)," ??" Q
;
SM W !!?3,"Enter 'MEDICATION' (or 'M', or press the RETURN key to have this patient's orders shown alphabetically by drug name. Enter 'DATE' (or 'D') to have this patient's orders shown by start date (the newest orders showing first)."
W " Enter a '^' to not show this patient's orders." Q
;
LCHK ;
I PSGOL?1."?" D LM Q
I PSGOL="" S PSGOL=$S('$D(PSJPDD):"S",'PSJPDD:"S",1:"L") W $S('$D(PSJPDD):" SHORT",'PSJPDD:" SHORT",1:" LONG") Q
I PSGOL?.E1L.E F Q=1:1:$L(PSGOL) I $E(PSGOL,Q)?1L S PSGOL=$E(PSGOL,1,Q-1)_$C($A(PSGOL,Q)-32)_$E(PSGOL,Q+1,$L(PSGOL))
F X="NO PROFILE","LONG","SHORT" I $P(X,PSGOL)="" W $P(X,PSGOL,2) S PSGOL=$E(PSGOL) Q
W:'$T $C(7)," ??" Q
;
LM W !!?3,"Enter 'SHORT' (or 'S', or press the RETURN key) to exclude this patient's",!,"discontinued and expired orders in the following profile. Enter 'LONG' (or 'L') to include those orders."
W " Enter 'NO' (or 'N') to bypass the profile com-",!,"pletely. Enter '^' if you wish to go no further with this patient." Q
;
ENU ; update staus field to reflect expired orders, if necessary
W !!,"...a few moments, I have some updating to do..."
ENUNM ;
D NOW^%DTC S PSGDT=%
F PSGO2=+PSJPAD:0 S PSGO2=$O(^PS(55,PSGP,5,"AUS",PSGO2)) Q:'PSGO2 Q:PSGO2>PSGDT F PSGO3=0:0 S PSGO3=$O(^PS(55,PSGP,5,"AUS",PSGO2,PSGO3)) Q:'PSGO3 S PSGO4=$G(^PS(55,PSGP,5,PSGO3,0)) D
.I PSGO4]"",$S($E($G(PSGALO),1,2)="10":"AHR"[$E($P(PSGO4,"^",9)),1:"AR"[$E($P(PSGO4,"^",9))) D ENUH
K PSGO1,PSGO2,PSGO3,PSGO4,UD Q
;
ENGORD ; get and sort orders
D NOW^%DTC S PSGDT=%,X1=$P(%,"."),X2=-2 D C^%DTC S PSGODT=X_(PSGDT#1),HDT=$$ENDTC^PSGMI(PSGDT),UDU=$S($P(PSJSYSU,";",3)>1:3,1:1) K ^TMP("PSG",$J)
W:'$D(PSGPR) !!,"...a few moments, please..." D ENUNM
F ST="C","O","OC","P","R" F SD=+PSJPAD:0 S SD=$O(^PS(55,PSGP,5,"AU",ST,SD)) Q:'SD F O=0:0 S O=$O(^PS(55,PSGP,5,"AU",ST,SD,O)) Q:'O D ECHK
Q:$D(PSGONNV)
NEW DRUGNAME
N PRNTON F SD="I","N" S (PRNTON,O)=0 F S O=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",ND=$G(^PS(53.1,O,0)) I $P(ND,"^",4)="U" D
. S ST=$P(ND,"^",7),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
. D DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
. S C=$S(P("PRNTON")]"":"BD",1:"BA") D SET
Q:+PSJSYSU'=3 S SD="P",O=0
N PRNTON F S (PRNTON,O)=$O(^PS(53.1,"AS",SD,PSGP,O)) Q:'O S ON=+O_"P",ND=$G(^PS(53.1,O,0)) I $P(ND,"^",4)="U" D
. S ST=$P(ND,"^",7),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
. D DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
. S C=$$CKPC^PSGOU(PSGP,$P(ND,U,25),O)
. I C="CB",$P($G(^PS(53.1,O,.2)),U,4)="S" S C="CA"
. I P("PRNTON")]"" S C="CD"
. D SET
Q
;
MAE ; change status to expired
ENUH ;
S $P(^PS(55,PSGP,5,PSGO3,0),"^",9)="E",ORIFN=$P(PSGO4,"^",21) I ORIFN D EN1^PSJHL2(PSGP,"SC",PSGO3_"U")
Q
;
CKPC(DFN,OLDON,NEWON) ; Compare old provider comments to new for speed finish.
N X,Y,Q,QQ,PSGOEEWF,PSJFLAG
I $P($G(^PS(53.1,+NEWON,0)),U,24)'="R" Q "CB"
S PSJFLAG=0,PSGOEEWF="^PS(55,"_DFN_","_$S(OLDON["V":"""IV""",1:5)_","_+OLDON_","
S (Q,QQ)=0 F S Q=$O(^PS(53.1,NEWON,12,Q)) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(@(PSGOEEWF_"12,"_Q_",0)")) I X'=Y S PSJFLAG=1 Q
I PSJFLAG!$O(@(PSGOEEWF_"12,"_QQ_")")) Q "CB"
S (Q,QQ)=0 F S Q=$O(@(PSGOEEWF_"12,"_Q_")")) Q:'Q S QQ=Q,X=$G(^(Q,0)),Y=$G(^PS(53.1,NEWON,12,Q,0)) I X'=Y S PSJFLAG=1 Q
I PSJFLAG!$O(^PS(53.1,+NEWON,12,QQ)) Q "CB"
Q "CC"
;
ENRNAT(OWD,NWD,SC,OAT) ; Determine admin times for renewal orders.
;OWD=ORIGINAL W, NWD=NEW WD LOCATION, SC=SCHEDULE, OAT=ORDER ADMIN TIMES
N OWAT,SCP,X,Y
S OOAT=OAT,SCP=+$O(^PS(51.1,"APPSJ",+SC,0)),WAT=$P($G(^PS(51.1,SCP,1,+$G(OWD),0)),U,2)
F X="WAT","OAT" F Y=1:1 Q:$L(@X)>240!($P(@X,"-",Y)="") S $P(@X,"-",Y)=$P(@X,"-",Y)_$E("0000",1,4-$L($P(@X,"-",Y)))
I OAT'=WAT Q OOAT
S X=$P($G(^PS(51.1,+SCP,1,NWD,0)),U,2) I X Q X
Q OOAT
PSGOU ;BIR/CML3,MV-PROFILE UTILITIES ;19 SEP 96 / 3:59 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**34,110**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(51.1 is supported by DBIA# 2177
+4 ; Reference to ^PS(55 is supported by DBIA# 2191.
+5 ;
ECHK ;
+1 ;***Store PSGDT with seconds.
DO NOW^%DTC
NEW PSGDT
SET PSGDT=%
+2 SET C="A"
SET ON=O_"U"
IF SD>PSGDT
GOTO DS
SET ND=$GET(^PS(55,PSGP,5,O,0))
IF $SELECT($PIECE(ND,"^",9)=""
GOTO DS
SET ND4=$GET(^(4))
+3 IF ST'="O"
IF SD'<PSGODT
IF $PIECE(ND,"^",9)="E"
IF $PIECE(ND4,"^",16)
GOTO DS
+4 IF ST="O"
IF $PIECE(ND,"^",9)'["D"
IF $SELECT('$PIECE(ND4,"^",UDU):1,SD<PSGODT:0,1:$PIECE(ND4,"^",16))
GOTO DS
+5 IF PSGOL="S"
QUIT
SET C="O"
+6 ;
DS ;
+1 NEW DRUGNAME
DO DRGDISP^PSJLMUT1(PSGP,+O_"U",80,0,.DRUGNAME,1)
SET DRG=DRUGNAME(1)
+2 ;
SET ;
+1 IF ON["P"
IF $GET(P("PRNTON"))]""
IF $GET(PRNTON)=+P("PRNTON")
QUIT
+2 IF ON["P"
IF $GET(P("PRNTON"))]""
SET PRNTON=+P("PRNTON")
SET ON=+P("PRNTON")
+3 SET ^TMP("PSG",$JOB,C,ST,DRG_"^"_ON)=$GET(NF)
+4 QUIT
+5 ;
ENS FOR S=0:0
READ !!,"Sort by DATE or MEDICATION: M// ",PSGOS:DTIME
DO SCHK
IF CHK
QUIT
+1 QUIT
+2 ;
ENL ;
+1 FOR
WRITE !!,"SHORT, LONG, or NO Profile? ",$SELECT('$DATA(PSJPDD):"SHORT",'PSJPDD:"SHORT",1:"LONG"),"// "
READ PSGOL:DTIME
IF '$TEST
WRITE $CHAR(7)
IF '$TEST
SET PSGOL="^"
IF PSGOL="^"
QUIT
DO LCHK
IF "^SLN"[PSGOL&($LENGTH(PSGOL)=1)
QUIT
+2 QUIT
+3 ;
SCHK ;
+1 IF '$TEST!(PSGOS["^")
SET PSGOS="^"
SET CHK=1
QUIT
+2 SET CHK=0
IF PSGOS["?"
DO SM
IF PSGOS["?"
QUIT
IF PSGOS=""
SET PSGOS="M"
SET CHK=1
WRITE "MEDICATION"
QUIT
+3 FOR X="DATE","MEDICATION"
IF $PIECE(X,PSGOS)=""
WRITE $PIECE(X,PSGOS,2)
SET PSGOS=$EXTRACT(PSGOS)
SET CHK=1
QUIT
+4 IF 'CHK
WRITE $CHAR(7)," ??"
QUIT
+5 ;
SM WRITE !!?3,"Enter 'MEDICATION' (or 'M', or press the RETURN key to have this patient's orders shown alphabetically by drug name. Enter 'DATE' (or 'D') to have this patient's orders shown by start date (the newest orders showing first)."
+1 WRITE " Enter a '^' to not show this patient's orders."
QUIT
+2 ;
LCHK ;
+1 IF PSGOL?1."?"
DO LM
QUIT
+2 IF PSGOL=""
SET PSGOL=$SELECT('$DATA(PSJPDD):"S",'PSJPDD:"S",1:"L")
WRITE $SELECT('$DATA(PSJPDD):" SHORT",'PSJPDD:" SHORT",1:" LONG")
QUIT
+3 IF PSGOL?.E1L.E
FOR Q=1:1:$LENGTH(PSGOL)
IF $EXTRACT(PSGOL,Q)?1L
SET PSGOL=$EXTRACT(PSGOL,1,Q-1)_$CHAR($ASCII(PSGOL,Q)-32)_$EXTRACT(PSGOL,Q+1,$LENGTH(PSGOL))
+4 FOR X="NO PROFILE","LONG","SHORT"
IF $PIECE(X,PSGOL)=""
WRITE $PIECE(X,PSGOL,2)
SET PSGOL=$EXTRACT(PSGOL)
QUIT
+5 IF '$TEST
WRITE $CHAR(7)," ??"
QUIT
+6 ;
LM WRITE !!?3,"Enter 'SHORT' (or 'S', or press the RETURN key) to exclude this patient's",!,"discontinued and expired orders in the following profile. Enter 'LONG' (or 'L') to include those orders."
+1 WRITE " Enter 'NO' (or 'N') to bypass the profile com-",!,"pletely. Enter '^' if you wish to go no further with this patient."
QUIT
+2 ;
ENU ; update staus field to reflect expired orders, if necessary
+1 WRITE !!,"...a few moments, I have some updating to do..."
ENUNM ;
+1 DO NOW^%DTC
SET PSGDT=%
+2 FOR PSGO2=+PSJPAD:0
SET PSGO2=$ORDER(^PS(55,PSGP,5,"AUS",PSGO2))
IF 'PSGO2
QUIT
IF PSGO2>PSGDT
QUIT
FOR PSGO3=0:0
SET PSGO3=$ORDER(^PS(55,PSGP,5,"AUS",PSGO2,PSGO3))
IF 'PSGO3
QUIT
SET PSGO4=$GET(^PS(55,PSGP,5,PSGO3,0))
Begin DoDot:1
+3 IF PSGO4]""
IF $SELECT($EXTRACT($GET(PSGALO),1,2)="10":"AHR"[$EXTRACT($PIECE(PSGO4,"^",9)),1:"AR"[$EXTRACT($PIECE(PSGO4,"^",9)))
DO ENUH
End DoDot:1
+4 KILL PSGO1,PSGO2,PSGO3,PSGO4,UD
QUIT
+5 ;
ENGORD ; get and sort orders
+1 DO NOW^%DTC
SET PSGDT=%
SET X1=$PIECE(%,".")
SET X2=-2
DO C^%DTC
SET PSGODT=X_(PSGDT#1)
SET HDT=$$ENDTC^PSGMI(PSGDT)
SET UDU=$SELECT($PIECE(PSJSYSU,";",3)>1:3,1:1)
KILL ^TMP("PSG",$JOB)
+2 IF '$DATA(PSGPR)
WRITE !!,"...a few moments, please..."
DO ENUNM
+3 FOR ST="C","O","OC","P","R"
FOR SD=+PSJPAD:0
SET SD=$ORDER(^PS(55,PSGP,5,"AU",ST,SD))
IF 'SD
QUIT
FOR O=0:0
SET O=$ORDER(^PS(55,PSGP,5,"AU",ST,SD,O))
IF 'O
QUIT
DO ECHK
+4 IF $DATA(PSGONNV)
QUIT
+5 NEW DRUGNAME
+6 NEW PRNTON
FOR SD="I","N"
SET (PRNTON,O)=0
FOR
SET O=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
IF 'O
QUIT
SET ON=+O_"P"
SET ND=$GET(^PS(53.1,O,0))
IF $PIECE(ND,"^",4)="U"
Begin DoDot:1
+7 SET ST=$PIECE(ND,"^",7)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,O,.2)),"^",8)
IF ST=""
SET ST="z"
+8 DO DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1)
SET DRG=DRUGNAME(1)
+9 SET C=$SELECT(P("PRNTON")]"":"BD",1:"BA")
DO SET
End DoDot:1
+10 IF +PSJSYSU'=3
QUIT
SET SD="P"
SET O=0
+11 NEW PRNTON
FOR
SET (PRNTON,O)=$ORDER(^PS(53.1,"AS",SD,PSGP,O))
IF 'O
QUIT
SET ON=+O_"P"
SET ND=$GET(^PS(53.1,O,0))
IF $PIECE(ND,"^",4)="U"
Begin DoDot:1
+12 SET ST=$PIECE(ND,"^",7)
SET P("PRNTON")=$PIECE($GET(^PS(53.1,O,.2)),"^",8)
IF ST=""
SET ST="z"
+13 DO DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1)
SET DRG=DRUGNAME(1)
+14 SET C=$$CKPC^PSGOU(PSGP,$PIECE(ND,U,25),O)
+15 IF C="CB"
IF $PIECE($GET(^PS(53.1,O,.2)),U,4)="S"
SET C="CA"
+16 IF P("PRNTON")]""
SET C="CD"
+17 DO SET
End DoDot:1
+18 QUIT
+19 ;
MAE ; change status to expired
ENUH ;
+1 SET $PIECE(^PS(55,PSGP,5,PSGO3,0),"^",9)="E"
SET ORIFN=$PIECE(PSGO4,"^",21)
IF ORIFN
DO EN1^PSJHL2(PSGP,"SC",PSGO3_"U")
+2 QUIT
+3 ;
CKPC(DFN,OLDON,NEWON) ; Compare old provider comments to new for speed finish.
+1 NEW X,Y,Q,QQ,PSGOEEWF,PSJFLAG
+2 IF $PIECE($GET(^PS(53.1,+NEWON,0)),U,24)'="R"
QUIT "CB"
+3 SET PSJFLAG=0
SET PSGOEEWF="^PS(55,"_DFN_","_$SELECT(OLDON["V":"""IV""",1:5)_","_+OLDON_","
+4 SET (Q,QQ)=0
FOR
SET Q=$ORDER(^PS(53.1,NEWON,12,Q))
IF 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(@(PSGOEEWF_"12,"_Q_",0)"))
IF X'=Y
SET PSJFLAG=1
QUIT
+5 IF PSJFLAG!$ORDER(@(PSGOEEWF_"12,"_QQ_")"))
QUIT "CB"
+6 SET (Q,QQ)=0
FOR
SET Q=$ORDER(@(PSGOEEWF_"12,"_Q_")"))
IF 'Q
QUIT
SET QQ=Q
SET X=$GET(^(Q,0))
SET Y=$GET(^PS(53.1,NEWON,12,Q,0))
IF X'=Y
SET PSJFLAG=1
QUIT
+7 IF PSJFLAG!$ORDER(^PS(53.1,+NEWON,12,QQ))
QUIT "CB"
+8 QUIT "CC"
+9 ;
ENRNAT(OWD,NWD,SC,OAT) ; Determine admin times for renewal orders.
+1 ;OWD=ORIGINAL W, NWD=NEW WD LOCATION, SC=SCHEDULE, OAT=ORDER ADMIN TIMES
+2 NEW OWAT,SCP,X,Y
+3 SET OOAT=OAT
SET SCP=+$ORDER(^PS(51.1,"APPSJ",+SC,0))
SET WAT=$PIECE($GET(^PS(51.1,SCP,1,+$GET(OWD),0)),U,2)
+4 FOR X="WAT","OAT"
FOR Y=1:1
IF $LENGTH(@X)>240!($PIECE(@X,"-",Y)="")
QUIT
SET $PIECE(@X,"-",Y)=$PIECE(@X,"-",Y)_$EXTRACT("0000",1,4-$LENGTH($PIECE(@X,"-",Y)))
+5 IF OAT'=WAT
QUIT OOAT
+6 SET X=$PIECE($GET(^PS(51.1,+SCP,1,NWD,0)),U,2)
IF X
QUIT X
+7 QUIT OOAT
