source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPORPR.m@ 1005

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

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1RMPORPR ;VA-EDS/PAK LIST HOME OXY PTS PRESCRIPTIONS/ITEMS ;7/24/98
2 ;;3.0;PROSTHETICS;**29,55**;Feb 09, 1996
3 ;
4 ; ODJ - patch 55 - re nois FGH-0800-33046 - make sure that if all
5 ; 12/5/00 patients option chosen dont print inactives
6 ;
7START ; Compile and print report
8 ;Set up the site.
9 D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
10 ;
11 ;Intialize variables.
12 K DIR,DIC,DIS,DIRUT,DUOUT,DTOUT,ALL
13 ;
14 ; Choose one or all patients
15 S DIR(0)="Y",DIR("A")="Select All Patients",DIR("B")="NO" D ^DIR
16 Q:Y="^"!$D(DTOUT) S ALL=Y
17 ; select patient
18 I 'ALL D SELP Q:Y<1 S (FR(1),TO(1))=Y(0,0),FR(2)=""
19 ; if all patients selected then print only those which are active
20 ; and are associated with current site.
21 I ALL S DIS(0)="I $P($G(^RMPR(665,D0,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,D0,""RMPOA"")),U,2)'="""",$P($G(^RMPR(665,D0,""RMPOA"")),U,3)=""""",(FR,TO)=""
22 ; compile report
23 D PRINT
24 D EXIT
25 Q
26 ;
27SELP ; Select patient
28 N DIR
29 S DIR(0)="P^665:EMZ"
30 S DIR("S")="I $P($G(^RMPR(665,Y,""RMPOA"")),U,7)=RMPOXITE,$P($G(^RMPR(665,Y,""RMPOA"")),U,2)'="""""
31 D ^DIR
32 Q
33 ;
34PRINT ; Print report
35 S $P(SP," ",80)="",(^TMP("RMPO",$J,"EXTC"),COUNT,PAGE,RMEND,RMPORPT)=0
36 S $P(BRK,"*",80)="*"
37 ; get current date to print in header
38 D NOW^%DTC S Y=% X ^DD("DD")
39 S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
40 ; define core print driver parameters
41 S DIC="^RMPR(665,",BY=".01,19.4,1",L=0 ; sort by patient,Rx then vendor
42 S DHD="W ?0 D RPTHDR^RMPORPR"
43 S DIOEND="I $G(Y)'[U D END^RMPORPR S RMEND=1 S:IOST[""P-"" RMPORPT=1"
44 ; print sub heading
45 S FLDS="""Date Current"";C50"
46 S FLDS(1)="""Name"";C1,""SSN"";C25,""Activation Date"";C33,""Prescription Expires"";50"
47 S FLDS(2)="""================="";C1,""===="";C25,""==============="";C33,""====================="";C50"
48 ; print patient name
49 S FLDS(3)=".01;C1;L22;""PATIENT"""
50 ; print SSN
51 S FLDS(4)="W $$SSN^RMPORPR;C25;R4;""SSN"""
52 ; print Rx activation date, expiry date & prescription detail
53 S FLDS(5)="19.3,.01;C33,2;C50,3;S;C1"
54 S FLDS(6)=""""";C1;S" ; spacer line
55 S FLDS(7)="19.4,1;C1;N" ; vendor - no duplicates
56 ; print item detail for current prescription
57 S FLDS(8)="""Fund"";C68;S"
58 S FLDS(9)=""""";C1"
59 S FLDS(10)="""Extended"";C57,""Control"";C68"
60 S FLDS(11)="""HCPCS"";C1,""Item"";C9,""Qty"";C32,""Unit Cost"";C42,""Cost"";C57,""Point"";C68"
61 S FLDS(12)="""-----"";C1,""----"";C9,""---"";C32,""---------"";C42,""----"";C57,""-----"";C68"
62 S FLDS(13)="19.4,W $$ADTL^RMPORPR;C1,6;C1;L8,.01;C9;L21,2;C32;L4,3;C42;L8,W $$COST^RMPORPR;C57,W $$FCP^RMPORPR;C68"
63 S FLDS(14)="W $$EXTC^RMPORPR;C1"
64 S FLDS(15)="""Inactivation Date: "";C1,19.5"
65 S FLDS(16)="""Inactivation Reason: "";C1,19.6"
66 S FLDS(17)="W BRK;C1"
67 S (RMPODFN,RMPOITEM)=0
68 D EN1^DIP
69 I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
70 Q
71 ;
72ADTL() ; Get Additional detail: cost, FCP and calculate total cost of all items
73 N REC,QTY,UCOST,COST,FCP
74 ;
75 I RMPODFN'=D0 S RMPODFN=D0,RMPOITEM=0
76 S RMPOITEM=$O(^RMPR(665,RMPODFN,"RMPOC",RMPOITEM)) Q:'+RMPOITEM ""
77 ;
78 ; quit if no items
79 I RMPOITEM="" S ^TMP("RMPO",$J,"ADTL")="" Q ""
80 ;
81 S REC=^RMPR(665,RMPODFN,"RMPOC",RMPOITEM,0)
82 S QTY=$P(REC,U,3),UCOST=$P(REC,U,4),FCP=$P($P(REC,U,6)," ")
83 S UCOST=UCOST*100,COST=QTY*UCOST,COST=$J(COST/100,0,2)
84 S ^TMP("RMPO",$J,"ADTL")=COST_U_FCP
85 S ^TMP("RMPO",$J,"EXTC")=$G(^TMP("RMPO",$J,"EXTC"))+COST
86 Q ""
87 ;
88COST() Q $P(^TMP("RMPO",$J,"ADTL"),U)
89 ;
90FCP() Q $P(^TMP("RMPO",$J,"ADTL"),U,2)
91 ;
92EXTC() ; Return extended cost
93 N EXTC
94 S EXTC=^TMP("RMPO",$J,"EXTC"),^TMP("RMPO",$J,"EXTC")=0
95 Q $E(SP,1,41)_"Total Cost"_$E(SP,1,5)_$J(EXTC,0,2)
96 ;
97EXIT ;
98 K COUNT,DTSTRG,SP,RD,RI,RNAM,BRK,X1,PAGE,RPTDT
99 K ROK,RY,DFN,VA,VADM,EXPDT,EXTC,RMPOITEM,RMPORX
100 K ^TMP("RMPO",$J) N RMPR,RMPRSITE D KILL^XUSCLEAN
101 Q
102 ;
103END ; End the report line
104 S COUNT=$E(" ",1,6-$L(COUNT))_COUNT
105 W !!,?50,"Total Patients: ",COUNT
106 Q
107 ;
108SSN() ; Get SSN
109 N X
110 K VA,VADM S DFN=D0 D ^VADPT
111 S X=$P(VA("PID"),"-",3)
112 I X'="" S COUNT=COUNT+1
113 Q X
114 ;
115SDT() ; Get Rx activation Date.
116 N X
117 ;
118 S X=$P($G(^RMPR(665,D0,"RMPOA")),U,2)
119 I X S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
120 Q X
121 ;
122EDT() ; Get the most recently entered Rx.
123 N RC,X
124 ;
125 S RMPORXDT=$O(^RMPR(665,D0,"RMPOB","B",""),-1)
126 ; if no prescription clear RMPORX and quit
127 I RMPORXDT="" S RMPORX="" Q 0
128 ; get Rx
129 S RMPORX=$O(^RMPR(665,D0,"RMPOB","B",RMPORXDT,""))
130 ; get Rx expire date
131 S RC=$P($G(^RMPR(665,D0,"RMPOB",RMPORX,0)),U,3)
132 Q $E(RC,4,5)_"/"_$E(RC,6,7)_"/"_($E(RC,1,3)+1700)
133 ;
134RPTHDR ; Report header
135 S PAGE=PAGE+1
136 W RPTDT,?(40-($L(RMPO("NAME"))/2)),RMPO("NAME"),?65,"Page: "_PAGE
137 W !,?23,"Prescription Report",!
138 Q
Note: See TracBrowser for help on using the repository browser.