source: FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGAP0.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.7 KB
Line 
1PSGAP0 ;BIR/CML3-ACTION PROFILE ;20 May 98 / 12:36 PM
2 ;;5.0; INPATIENT MEDICATIONS ;**8,58,111**;16 DEC 97
3 ;
4 ; Reference to ^PS(55 is supported by DBIA# 2191
5 ;
6GOD ; gather order data
7 S ND=$G(^PS(55,PSGP,5,PSJJORD,0)),ND2=$G(^(2)),SI=$P($G(^(6)),"^"),DRG=$G(^(.2)) ;WS=$S(DRG&PSGAPWD:$D(^PSI(58.1,"D",+DRG,PSGAPWD)),1:0),DRG=$G(^PS(50.7,+DRG,0))
8 ;S NF=$P(DRG,"^",9)
9 S X=$$NFWS^PSJUTL1(PSGP,PSJJORD_"U",PSGAPWD) S NF=$P(X,U),WS=$P(X,U,2),SM=$S('$P(X,U,3):0,$P(X,U,4):1,1:2)
10 N X,PSG
11 D DRGDISP^PSJLMUT1(PSGP,PSJJORD_"U",40,0,.PSG,1)
12 S DRG=PSG(1),DRG=$S(DRG["NOT FOUND":"z",1:DRG)
13 S ST=$P(ND,"^",9),ND=$P(ND,"^",7),SD=$P(ND2,"^",2),FD=$P(ND2,"^",4)
14 I STP'=9999999\1,(SD>STP) Q
15 F X="SD","FD" S @X=$E($$ENDTC^PSGMI(@X),1,5)
16 ;
17 S Y=SI S:Y]"" Y=$$ENSET^PSGSICHK(Y) S X=ND_U_$E(DRG,1,20),^TMP($J,$E(PSGAPWDN,1,20),TM,PN,X,+PSJJORD)=ST_U_SD_U_FD_U_WS_U_SM_U_NF S:Y]"" ^(PSJJORD,1)=Y
18 Q
19 ;
20PAT ;
21 ;;S RB=$G(^DPT(PSGP,.101)),TM="zz" S:RB]"" TM=$S('$D(PSGAPTM):"zz",1:$O(^PS(57.7,"AWRT",PSGAPWD,RB,0))) I PSGAPWDN="" S PSGAPWDN="* NF *"
22 S RB=$G(^DPT(PSGP,.101)) S:RB]"" TM=$S('$D(PSGAPTM):"zz",1:$O(^PS(57.7,"AWRT",PSGAPWD,RB,0))) S:$G(TM)="" TM="zz" I PSGAPWDN="" S PSGAPWDN="* NF *"
23 I $D(PSGAPTM) S ATM="",ATM=$O(PSGAPTM(ATM)) I ATM'="ALL" Q:'$D(PSGAPTM(+TM))
24 S:TM'="zz" TM=^PS(57.7,PSGAPWD,1,TM,0)
25 S PSJACNWP=1 D PSJAC2^PSJAC(1),NOW^%DTC S PSGDT=%,PND=PSGP(0),PN=$S($G(PSJSEL("RBP"))="R":RB,1:"")_"^"_$E($P(PND,"^"),1,20)_"^"_PSGP
26 I '$G(STT) S STT=PSGDT,STP=9999999
27 S:PSGMTYPE[1 PSGMTYPE="2,3,4,5,6"
28 I PSGMTYPE[2 D
29 . F STRT=STT:0 S STRT=$O(^PS(55,PSGP,5,"AUS",STRT)) Q:'STRT F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",STRT,PSJJORD)) Q:'PSJJORD D GOD
30 . S XTYPE=2,PST="S" D ^PSGAPIV
31 N XTYPE F XTYPE=3:1:6 I PSGMTYPE[XTYPE S PST=$S(XTYPE=3:"P",XTYPE=4:"A",XTYPE=5:"H",1:"C") D ^PSGAPIV
32 I PSGMTYPE[3 S XTYPE=3,PST="S" D ^PSGAPIV ;* Find syringe type iv
33 I $D(^TMP($J,$E(PSGAPWDN,1,20),TM,PN)) D
34 . ;naked reference on line below refers to full global reference on line above
35 . S ^(PN)=$P(PSJPSEX,"^",2)_"^"_$E($P(PSJPDOB,"^",2),1,10)_";"_PSJPAGE_"^"_VA("PID")_"^"_PSJPDX_"^"_$S(PSJPRB]"":PSJPRB,1:"*NF*")_"^"_$E($P(PSJPAD,"^",2),1,10)_"^"_$E($P(PSJPTD,"^",2),1,10)_"^"_+PSJPWT
36 . S:($G(PSJSEL("WG"))="^OTHER") ^TMP("PSGAP0",$J,"OUTPT",PSGP)=""
37 Q
38 ;
39GDT ;
40 K %DT S %DT="EFTX",Y=-1,%DT(0)=$S(N["R":PSGDT,1:STT) F W !!,"Enter ",N," date/time: " R X:DTIME W:'$T $C(7) S:'$T X="^" Q:"^"[X D DTM:X?1."?",^%DT Q:Y>0
41 I X'="^" S:N["R" STT=$S(Y'>0:PSGDT,Y#1:+$E(Y,1,12),1:Y+.0002)-.0001 S:N["O" STP=$S(Y'>0:9999999,Y#1:+$E(Y,1,12),1:Y+.24)
42 K %DT Q
43 ;
44EN ; entry point
45 I PSGSS'="P" D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT F N="START","STOP" D GDT I X="^" S PSJSTOP=1 Q
46 I PSGSS'="P" Q:X="^" S:'$P(STP,".",2) $P(STP,".",2)=24 S:'$P(STT,".",2) $P(STT,".",2)="0001"
47 S PSJSTOP=$$MEDTYPE^PSJMDIR($G(PSGWD)) Q:PSJSTOP S PSGMTYPE=Y
48 K ZTSAVE S:PSGSS'="P" (ZTSAVE("STT"),ZTSAVE("STP"))="" F X="PSGP","PSGSS","PSGAPWD","PSGAPWG","PSGAPWDN","PSGAPWGN","PSGPAT(","PSGAPTM(","PSGMTYPE","PSGPTMP","PSJSEL(","PSJOS","PPAGE" S ZTSAVE(X)=""
49 W !,"...this may take a few minutes...(you should QUEUE this report)..."
50 S PSGTIR="ENQ^PSGAP0",ZTDESC="ACTION PROFILE" D ENDEV^PSGTI S:POP PSJSTOP=1 Q:POP!$D(IO("Q"))
51 ;
52ENQ ; queued entry point
53 K ^TMP("PSGAP0",$J) N RB,ATM,TM,DRGI,DRGN,DRGT,ON,PST,PSIVUP,PSJORIFN,QST,SLS,XTYPE
54 D @("P"_PSGSS),^PSGAPP D ^%ZISC K ^TMP("PSGAP0",$J)
55 Q
56 ;
57PG ;
58 I $G(PSJSEL("WG"))="^OTHER" D CLIN Q
59 F PSGAPWD=0:0 S PSGAPWD=$O(^PS(57.5,"AC",PSGAPWG,PSGAPWD)) Q:'PSGAPWD I $D(^DIC(42,PSGAPWD,0)),$P(^(0),"^")]"" S PSGAPWDN=$P(^(0),"^") D PW
60 Q
61 ;
62CLIN ;
63 F INDEX="AIVC","AUDC" S STOP=0 F S STOP=$O(^PS(55,INDEX,STOP)) Q:'STOP S CLIN=0 F S CLIN=$O(^PS(55,INDEX,STOP,CLIN)) Q:'CLIN D
64 . S DFN=0 F S DFN=$O(^PS(55,INDEX,STOP,CLIN,DFN)) Q:'DFN I '$D(^TMP("PSGAP0",$J,"OUTPT",DFN)) D
65 .. S PSGP=DFN,Q=STOP N STOP D PAT
66 Q
67 ;
68PW ;
69 F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGAPWDN,PSGP)) Q:'PSGP D
70 .S Q=$O(^PS(55,PSGP,5,"AUS",STT)) I Q D PAT Q
71 .S Q=$O(^PS(55,PSGP,"IV","AIS",STT)) I Q D PAT
72 Q
73 ;
74PP ;
75 F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP S PSGAPWDN=$P($G(^DPT(PSGP,.1)),"^") S:PSGAPWDN]"" PSGAPWD=+$O(^DIC(42,"B",PSGAPWDN,0)) D PAT
76 Q
77 ;
78DTM ;
79 S Y=%DT(0) D D^DIQ S T=$P(Y,"@",2),Y=$P(Y,",")
80 W !!?2,"If a ",N," date is entered, an action profile will print for only those",!,"patients that have at least one active order with a ",$S(N["A":"STOP",1:"START")," DATE on or ",$S(N["A":"after",1:"before"),!,"the ",N," date entered."
81 W !?2,"Entry is not required. If neither date is entered, all patients with active",!,"orders will print (for the ward(s) chosen). Enter an up-arrow (^) to exit."
82 W !?2,"If you wish to enter a ",$S(N["R":"start",1:"stop")," date of ",Y,", you must enter a TIME of day",!,"of ",T," or greater. Any date after ",Y," does not need time entered.",! S Y=-1 Q
Note: See TracBrowser for help on using the repository browser.