source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOU.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.0 KB
Line 
1PSGOU ;BIR/CML3,MV-PROFILE UTILITIES ;19 SEP 96 / 3:59 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**34,110**;16 DEC 97
3 ;
4 ; Reference to ^PS(51.1 is supported by DBIA# 2177
5 ; Reference to ^PS(55 is supported by DBIA# 2191.
6 ;
7ECHK ;
8 D NOW^%DTC N PSGDT S PSGDT=% ;***Store PSGDT with seconds.
9 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))
10 I ST'="O",SD'<PSGODT,$P(ND,"^",9)="E",$P(ND4,"^",16) G DS
11 I ST="O",$P(ND,"^",9)'["D",$S('$P(ND4,"^",UDU):1,SD<PSGODT:0,1:$P(ND4,"^",16)) G DS
12 Q:PSGOL="S" S C="O"
13 ;
14DS ;
15 NEW DRUGNAME D DRGDISP^PSJLMUT1(PSGP,+O_"U",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
16 ;
17SET ;
18 I ON["P",$G(P("PRNTON"))]"",$G(PRNTON)=+P("PRNTON") Q
19 I ON["P",$G(P("PRNTON"))]"" S PRNTON=+P("PRNTON"),ON=+P("PRNTON")
20 S ^TMP("PSG",$J,C,ST,DRG_"^"_ON)=$G(NF)
21 Q
22 ;
23ENS F S=0:0 R !!,"Sort by DATE or MEDICATION: M// ",PSGOS:DTIME D SCHK Q:CHK
24 Q
25 ;
26ENL ;
27 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)
28 Q
29 ;
30SCHK ;
31 I '$T!(PSGOS["^") S PSGOS="^",CHK=1 Q
32 S CHK=0 D:PSGOS["?" SM Q:PSGOS["?" I PSGOS="" S PSGOS="M",CHK=1 W "MEDICATION" Q
33 F X="DATE","MEDICATION" I $P(X,PSGOS)="" W $P(X,PSGOS,2) S PSGOS=$E(PSGOS),CHK=1 Q
34 W:'CHK $C(7)," ??" Q
35 ;
36SM 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)."
37 W " Enter a '^' to not show this patient's orders." Q
38 ;
39LCHK ;
40 I PSGOL?1."?" D LM Q
41 I PSGOL="" S PSGOL=$S('$D(PSJPDD):"S",'PSJPDD:"S",1:"L") W $S('$D(PSJPDD):" SHORT",'PSJPDD:" SHORT",1:" LONG") Q
42 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))
43 F X="NO PROFILE","LONG","SHORT" I $P(X,PSGOL)="" W $P(X,PSGOL,2) S PSGOL=$E(PSGOL) Q
44 W:'$T $C(7)," ??" Q
45 ;
46LM 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."
47 W " Enter 'NO' (or 'N') to bypass the profile com-",!,"pletely. Enter '^' if you wish to go no further with this patient." Q
48 ;
49ENU ; update staus field to reflect expired orders, if necessary
50 W !!,"...a few moments, I have some updating to do..."
51ENUNM ;
52 D NOW^%DTC S PSGDT=%
53 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
54 .I PSGO4]"",$S($E($G(PSGALO),1,2)="10":"AHR"[$E($P(PSGO4,"^",9)),1:"AR"[$E($P(PSGO4,"^",9))) D ENUH
55 K PSGO1,PSGO2,PSGO3,PSGO4,UD Q
56 ;
57ENGORD ; get and sort orders
58 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)
59 W:'$D(PSGPR) !!,"...a few moments, please..." D ENUNM
60 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
61 Q:$D(PSGONNV)
62 NEW DRUGNAME
63 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
64 . S ST=$P(ND,"^",7),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
65 . D DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
66 . S C=$S(P("PRNTON")]"":"BD",1:"BA") D SET
67 Q:+PSJSYSU'=3 S SD="P",O=0
68 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
69 . S ST=$P(ND,"^",7),P("PRNTON")=$P($G(^PS(53.1,O,.2)),"^",8) S:ST="" ST="z"
70 . D DRGDISP^PSJLMUT1(PSGP,+O_"P",80,0,.DRUGNAME,1) S DRG=DRUGNAME(1)
71 . S C=$$CKPC^PSGOU(PSGP,$P(ND,U,25),O)
72 . I C="CB",$P($G(^PS(53.1,O,.2)),U,4)="S" S C="CA"
73 . I P("PRNTON")]"" S C="CD"
74 . D SET
75 Q
76 ;
77MAE ; change status to expired
78ENUH ;
79 S $P(^PS(55,PSGP,5,PSGO3,0),"^",9)="E",ORIFN=$P(PSGO4,"^",21) I ORIFN D EN1^PSJHL2(PSGP,"SC",PSGO3_"U")
80 Q
81 ;
82CKPC(DFN,OLDON,NEWON) ; Compare old provider comments to new for speed finish.
83 N X,Y,Q,QQ,PSGOEEWF,PSJFLAG
84 I $P($G(^PS(53.1,+NEWON,0)),U,24)'="R" Q "CB"
85 S PSJFLAG=0,PSGOEEWF="^PS(55,"_DFN_","_$S(OLDON["V":"""IV""",1:5)_","_+OLDON_","
86 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
87 I PSJFLAG!$O(@(PSGOEEWF_"12,"_QQ_")")) Q "CB"
88 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
89 I PSJFLAG!$O(^PS(53.1,+NEWON,12,QQ)) Q "CB"
90 Q "CC"
91 ;
92ENRNAT(OWD,NWD,SC,OAT) ; Determine admin times for renewal orders.
93 ;OWD=ORIGINAL W, NWD=NEW WD LOCATION, SC=SCHEDULE, OAT=ORDER ADMIN TIMES
94 N OWAT,SCP,X,Y
95 S OOAT=OAT,SCP=+$O(^PS(51.1,"APPSJ",+SC,0)),WAT=$P($G(^PS(51.1,SCP,1,+$G(OWD),0)),U,2)
96 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)))
97 I OAT'=WAT Q OOAT
98 S X=$P($G(^PS(51.1,+SCP,1,NWD,0)),U,2) I X Q X
99 Q OOAT
Note: See TracBrowser for help on using the repository browser.