source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPRN.m@ 1424

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

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1PSBPRN ;BIRMINGHAM/EFC-BCMA PRN FUNCTIONS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**5,3,13**;Mar 2004
3 ;
4 ;Reference/IA
5 ;DEM^VADPT/10061
6 ;INP^VADPT/10061
7 ;$$GET1^DIQ/2056
8EN ;
9 Q
10 ;
11EDIT ; Edit Medication Log PRN Effectiveness
12 NEW DFN ;* Undef DFN at EDIT+7^PSBPRN (NOIS: HUN-0699-21494)
13 W !! S DA=""
14 S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select Patient Name: "
15 D ^DIC K DIC Q:+Y<1
16 S DFN=+Y
17 D EDIT1
18 K DFN,DA
19 G EDIT
20 ;
21EDIT1 ;
22 S %DT="AEQ",%DT("A")="Select Date to Begin Searching Back From: "
23 S %DT("B")="Today"
24 W !! D ^%DT Q:+Y<1 S PSBDT=Y
25 F D Q:'PSBDT
26 .W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y
27 .W !," # Medication",?45,"St",?50,"D/T Given",?75,"Int"
28 .W !,$TR($J("",IOM)," ","-")
29 .S PSBSRCH=PSBDT+.9,PSBCNT=0
30 .K PSBTMP
31 .F S PSBSRCH=$O(^PSB(53.79,"APRN",DFN,PSBSRCH),-1) Q:'PSBSRCH!(PSBSRCH<PSBDT) D
32 ..S PSBIEN=""
33 ..F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSRCH,PSBIEN),-1) Q:'PSBIEN D
34 ...Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]""
35 ...Q:$P($G(^PSB(53.79,PSBIEN,0)),U,9)'="G"
36 ...S PSBCNT=PSBCNT+1,PSBTMP(PSBCNT)=PSBIEN
37 ...I $Y>19 W ! S DIR(0)="E" D ^DIR W @IOF,!,"Searching Date " S Y=PSBDT D D^DIQ W Y,!," # Medication",?45,"St",?50,"D/T Given",?75,"Int",!,$TR($J("",IOM)," ","-")
38 ...W !,$J(PSBCNT,2),". "
39 ...W ?5,$$GET1^DIQ(53.79,PSBIEN_",",.08)
40 ...W ?45,$P(^PSB(53.79,PSBIEN,0),U,9)
41 ...W ?50,$$GET1^DIQ(53.79,PSBIEN_",",.06)
42 ...W ?75,$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
43 .I PSBCNT W ! S DIR(0)="NO^1:"_PSBCNT_":0" D ^DIR S:Y DA=PSBTMP(Y),PSBDT="" Q:Y
44 .I 'PSBCNT W !!?5,"No Meds Found!"
45 .S X1=PSBDT,X2=-1 D C^%DTC S (PSBDT,Y)=X D D^DIQ
46 .W !!,"Continue With ",Y
47 .S %=1 D YN^DICN I %'=1 S PSBDT=0
48 I DA S DDSFILE=53.79,DR="[PSB PRN EFFECTIVENESS]" D ^DDS S %=2 W !,"Edit another entry" D YN^DICN G:%=1 EDIT1
49 K PSBCNT,PSBDT,PSBIEN,PSBSRCH,PSBTMP,DA,DR,DDSFILE
50 Q
51 ;
52GETPRNS(RESULTS,DFN,PSBORD) ; Get the PRN's for a pt needing effectness
53 ;
54 ; RPC PSB GETPRNS
55 ;
56 ; Description:
57 ; Returns all administrations of a PRN order that have NOT had
58 ; the PRN Effectiveness documented BASED ON THE TRANSFER DATE AND SITE PARAM
59 ;
60 N PSBIEN,PSBSTOP
61 K ^TMP("PSB",$J),RESULTS
62 ;
63 Q:$$DISCHRGD(DFN)
64 ;
65 D INP^VADPT S PSBTRDT=+VAIN(7)
66 S PSBHOUR=$$GET^XPAR("DIV","PSB PRN DOCUMENTATION") I PSBHOUR="" S PSBHOUR=72
67 D NOW^%DTC S PSBSTRT=%,PSBPRNDT=$$FMADD^XLFDT(PSBSTRT,"",-PSBHOUR)
68 ;
69 ;Use the (OLDER) value of PSBPRNDT(site param) or PSBTRDT(admission)
70 I PSBPRNDT>PSBTRDT S PSBPRNDT=PSBTRDT
71 S PSBSTRT="" F S PSBSTRT=$O(^PSB(53.79,"APRN",DFN,PSBSTRT),-1) Q:(PSBSTRT<PSBPRNDT) D
72 .S PSBIEN=""
73 .F S PSBIEN=$O(^PSB(53.79,"APRN",DFN,PSBSTRT,PSBIEN),-1) Q:'PSBIEN D
74 ..Q:(PSBORD'="")&($P(^PSB(53.79,PSBIEN,.1),U)'=PSBORD) ; Not the right order
75 ..I ($P(^PSB(53.79,PSBIEN,0),U,9)'="G")&($P(^PSB(53.79,PSBIEN,0),U,9)'="RM") Q ; Med was never given
76 ..Q:$P($G(^PSB(53.79,PSBIEN,.2)),U,2)]"" ; Already entered
77 ..S PSBX=PSBIEN_U_DFN,PSBIENS=PSBIEN_","
78 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.02)
79 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.06,"I")
80 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.07)
81 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.08)
82 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.21)
83 ..D PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBIENS,.11))
84 ..S PSBX=PSBX_U_PSBOIT_U_PSBONX
85 ..S PSBX=PSBX_U_$$GET1^DIQ(53.79,PSBIENS,.27)
86 ..S Y=$O(^TMP("PSB",$J,""),-1)+1
87 ..S ^TMP("PSB",$J,Y)=PSBX
88 ..;Special instructions
89 ..S Y=Y+1,^TMP("PSB",$J,Y)=PSBOTXT
90 ..F PSBZ=.5,.6,.7 F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBIEN,PSBZ,PSBY)) Q:'PSBY D
91 ...S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
92 ...S PSBSOL=$S(PSBZ=.5:"DD",PSBZ=.6:"ADD",1:"SOL")
93 ...Q:'$D(^PSB(53.79,PSBIEN,PSBZ,PSBY))
94 ...S PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.03)
95 ...S PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.04)
96 ...S Y=Y+1
97 ...S ^TMP("PSB",$J,Y)=PSBSOL_U_$$GET1^DIQ(PSBDD,PSBY_","_PSBIEN_",",.01)_U_PSBUNIT_U_PSBUNFR
98 ..S Y=Y+1,^TMP("PSB",$J,Y)="END"
99 S ^TMP("PSB",$J,0)=+$O(^TMP("PSB",$J,""),-1)
100 S RESULTS=$NAME(^TMP("PSB",$J))
101 K PSBTRDT,PSBHOUR,PSBPRNDT
102 D CLEAN^PSBVT
103 Q
104 ;
105DISCHRGD(DFN) ; Patient Discharged OR Deceased?
106 ;
107 S DISCHRGD=0
108 ;
109 D DEM^VADPT ;check for date of death entry
110 I VADM(6)]"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VADM
111 ;
112 I DISCHRGD=0 D ;check for discharge if they're not dead
113 .D INP^VADPT
114 .I VAIN(1)']"" S DISCHRGD=1,^TMP("PSB",$J,0)=0 K VAIN
115 ;
116 I DISCHRGD D ;setup results and clean up
117 .S RESULTS=$NAME(^TMP("PSB",$J))
118 .K PSBTRDT,PSBHOUR,PSBPRNDT
119 .D CLEAN^PSBVT
120 ;
121 Q DISCHRGD
122 ;
Note: See TracBrowser for help on using the repository browser.