source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMT1.m@ 1404

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1PSBOMT1 ;BIRMINGHAM/TEJ-BCMA MEDICATION THERAPY REPORT ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; File 50.7/2880
7 ; File 52.6/436
8 ; File 52.7/437
9 ; File 200/10060
10 ; EN^PSJBCMA1/2829
11 ; IEN^PSN50P65/4543
12 ; DRGIEN^PSS50P7/4662
13 ; VAC^PSS50/4533
14GETADSO ; GET ALL ADDITIVES FOR ALL ORDERABLE ITEMS
15 K PSBAOUT,PSBSOUT
16 S XA="" F S XA=$O(PSBOIP("OIP",XA)) Q:XA="" D
17 .D LIST^DIC(52.6,"","@;15I","QPI","","","","AOI","","","PSBAOUT")
18 .S XB=0 F S XB=$O(PSBAOUT("DILIST",XB)) Q:XB="" D
19 ..I $P(PSBAOUT("DILIST",XB,0),"^",2)=XA D
20 ...S TMP("PSBADDS",$J,$P(PSBAOUT("DILIST",XB,0),"^",1))=""
21 K PSBAOUT
22 ; GET ALL SOLUTIONS FOR ALL ORDERABLE ITEMS
23 S XA="" F S XA=$O(PSBOIP("OIP",XA)) Q:XA="" D
24 .D LIST^DIC(52.7,"","@;9I","QPI","","","","AOI","","","PSBSOUT")
25 .S XB=0 F S XB=$O(PSBSOUT("DILIST",XB)) Q:XB="" D
26 ..I $P(PSBSOUT("DILIST",XB,0),"^",2)=XA D
27 ...S TMP("PSBSOLS",$J,$P(PSBSOUT("DILIST",XB,0),"^",1))=""
28 K PSBSOUT
29 Q
30FINDIENS ; USE PSBOIS,PSBADDS AND PSBSOLS TO FIND ALL IENS FOR THE RPT
31 ;SEARCH FOR UNIT DOSE IENS
32 I $D(TMP("PSBOIS",$J)) S XA="" F S XA=$O(TMP("PSBOIS",$J,XA)) Q:XA="" D
33 .S PSBDT=PSBSTRT F S PSBDT=$O(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT)) Q:PSBDT=""!(PSBDT>PSBSTOP) D
34 ..S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP",PSBXDFN,XA,PSBDT,PSBIEN)) Q:PSBIEN="" D
35 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
36 ...S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
37 ;SEARCH FOR ADDITIVES
38 I $D(TMP("PSBADDS",$J)) S XA="" F S XA=$O(TMP("PSBADDS",$J,XA)) Q:XA="" D
39 .S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN)) Q:PSBIEN="" D
40 ..S XB="" F S XB=$O(^PSB(53.79,"AOIP3",PSBXDFN,PSBIEN,XB)) Q:XB="" D
41 ...Q:XB'=XA
42 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
43 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,($P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP) D
44 ....S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
45 ;SEARCH FOR SOLUTIONS
46 I $D(TMP("PSBSOLS",$J)) S XA="" F S XA=$O(TMP("PSBSOLS",$J,XA)) Q:XA="" D
47 .S PSBIEN="" F S PSBIEN=$O(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN)) Q:PSBIEN="" D
48 ..S XB="" F S XB=$O(^PSB(53.79,"AOIP4",PSBXDFN,PSBIEN,XB)) Q:XB="" D
49 ...Q:XB'=XA
50 ...Q:$P(^PSB(53.79,PSBIEN,0),U,9)="N"
51 ...I $P(^PSB(53.79,PSBIEN,0),"^",6)>PSBSTRT,($P(^PSB(53.79,PSBIEN,0),"^",6)<PSBSTOP) D
52 ....S TMP("PSBIENS",$J,$$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),PSBIEN)=""
53 Q
54HDR ; Header
55 W:$Y>1 @IOF
56 W:$X>1 !
57 S PSBRPNM="BCMA MEDICATION THERAPY REPORT"
58 S PSBPGNUM=1,PSBOUTP(0)="",PSBRPT(0)=""
59 S PSBPG="Page: "_PSBPGNUM_" of "_$S($O(PSBOUTP(""),-1)=0:1,1:$O(PSBOUTP(""),-1))
60 I $P(PSBRPT(0),U,4)="" S $P(PSBRPT(0),U,4)=DUZ(2)
61 S PSBPGRM=IOM-($L(PSBPG))
62 D:$P(PSBRPT(.1),U,1)="P"
63 .K PSBHDR
64 .S PSBHDR(1)="BCMA MEDICATION THERAPY REPORT for "
65 .S Y=$P(PSBRPT(.1),U,6) D D^DIQ S PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,7) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)_" to "
66 .S Y=$P(PSBRPT(.1),U,8) D D^DIQ S PSBHDR(1)=PSBHDR(1)_Y_"@" S Y=$P(PSBRPT(.1),U,9) S PSBHDR(1)=PSBHDR(1)_$E(Y_"0000",2,5)
67 .S PSBHDR(2)="Schedule Type(s): --"
68 .F Y=1:1:4 I $P(PSBRPT(.2),U,Y) S $P(PSBHDR(2),": ",2)=$P(PSBHDR(2),": ",2)_$S(PSBHDR(2)["--":"",1:"/ ")_$P("Continuous^PRN^On-Call^One-Time",U,Y)_" " S PSBHDR(2)=$TR(PSBHDR(2),"-","")
69 .I PSBCFLG S PSBHDR(3)="Include Comments" S PSBHDR(4)=" "
70 .E S PSBHDR(3)=" "
71 Q
72LEGEND ; Report Legend
73 K PSBLGDO
74 S PSBLGD("ORDER TYPES","C")="Continuous"
75 S PSBLGD("ORDER TYPES","O")="One Time"
76 S PSBLGD("ORDER TYPES","OC")="On Call"
77 S PSBLGD("ORDER TYPES","P")="PRN (As Needed)"
78 S PSB=0 F S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0 D
79 .S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
80 .K PSBLGD("INITIALS",PSB)
81 S PSBLGDO(0)="REPORT LEGEND"
82 S PSBLGDO(1)=""
83 S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
84 S PSBLGDO(3)=""
85 I '$G(PSBNO,0) S X1="",X2=3 F S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1="" S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
86 I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F S X1=$O(PSBLGD("INITIALS",X1)) Q:X1="" S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
87 I ($Y+$O(PSBLGDO(""),-1))>(IOSL-12) D
88 .W $$PTFTR^PSBOHDR()
89 .D PT^PSBOHDR(PSBXDFN,.PSBHDR)
90 I IOSL<1000 F Q:($Y+$O(PSBLGDO(""),-1)+12)>IOSL W !
91 W !,$TR($J("",IOM)," ","="),!
92 F X1=$O(PSBLGDO("")):1:$O(PSBLGDO(""),-1) W !,PSBLGDO(X1)
93 W !!,$TR($J("",IOM)," ","="),!
94 Q
95FTR ;
96 I (IOSL<100) F Q:$Y>(IOSL-6) W !
97 W !,$TR($J("",IOM)," ","=")
98 S X="Ward: "_PSBHDR("WARD")_" Room-Bed: "_PSBHDR("ROOM")
99 W !,PSBHDR("NAME"),?(IOM-11\2),PSBHDR("SSN"),?(IOM-$L(X)),X
100 W !,"BCMA MEDICATION THERAPY REPORT",?(IOM-$L(PSBDTTM)),PSBDTTM
101 Q
102MAKELINE(X,CNT) ;LINE OF WHAT'S PASSED IN CNT TIMES
103 N Y,Z
104 S Y=""
105 F Z=1:1:CNT S Y=Y_X
106 Q Y
107 ;
108PARSE(X,CNT) ;Split text for wrapping.
109 S CNTX="UOA"_CNT,@CNTX=@CNTX_$E(X,CNT,(CNT+14)),UOAX=""
110 F S:$F(@CNTX,", ",+UOAX)>0 UOAX=$F(@CNTX,", ",+UOAX) Q:'$F(@CNTX,", ",+UOAX)
111 I UOAX<1 F S:$F(@CNTX," ",+UOAX)>0 UOAX=$F(@CNTX," ",+UOAX) Q:'$F(@CNTX," ",+UOAX)
112 I UOAX>1,(($L(UOA)-(CNT+14))>0) S CNTXX=$E(@CNTX,1,UOAX-1),@("UOA"_(CNT+15))=$E(@CNTX,UOAX,UOAX+14),@CNTX=CNTXX
113 Q
114 ;
115PAD(X,CNT) ;
116 Q $E(X_$J("",CNT),1,CNT)
117 ;
118CLEANALL ; KILL ALL TMP LEVELS USED VARIABLES
119 K ^TMP("PSB",$J),^TMP("PSJ1",$J),PSBOIP,TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
120 K TMP("PSBIENS",$J)
121 Q
122 ;
123CLEANSUM ; KILL ALL BUN THE "PSBIENS" LEVEL
124 K ^TMP("PSB",$J),^TMP("PSJ1",$J),TMP("PSBIENS",$J),TMP("PSBOIS",$J),TMP("PSBADDS",$J),TMP("PSBSOLS",$J)
125 Q
Note: See TracBrowser for help on using the repository browser.