source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPORPT.m@ 1590

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

initial load of FOIAVistA 6/30/08 version

File size: 3.1 KB
Line 
1RMPORPT ;(NG)/DG/CAP /HINES CIOFO/HNC - Home Oxygen Primary Item Report ;7/24/98
2 ;;3.0;PROSTHETICS;**29,46**;Feb 09, 1996
3SITE ;Set up site variables.
4 D HOSITE^RMPOUTL0 I '$D(RMPOXITE) Q
5 ;
6LI ;List the sought patient.
7 N PBREAK,NBREAK S (PBREAK,NBREAK)=""
8 S DIC="^RMPR(665,"
9 S BY(0)="^TMP($J,",L(0)=3
10 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)="""""
11 S L=0,FR="",(PAGE,RMEND,RMPORPT)=0
12 S $P(SPACE," ",80)="",COUNT=0
13 D NOW^%DTC
14 S Y=% X ^DD("DD") S RPTDT=$P(Y,"@",1)_" "_$P($P(Y,"@",2),":",1,2)
15 S DHD="W ?0 D RPTHDR^RMPORPT"
16 S DIOEND="I $G(Y)'[U S COUNT=$E("" "",1,(6-$L(COUNT)))_COUNT W !!,?50,""Total Patients: "",COUNT S RMEND=1 S:IOST[""P-"" RMPORPT=1"
17 ;S DIOEND="S:$G(Y)[U RMEND=1 I '$G(RMEND) S COUNT=$E("" "",1,(6-$L(COUNT)))_COUNT W !!,?50,""Total Patients: "",COUNT"
18 S FLDS="D PBREAK^RMPORPT,.01;C1;L18;""PATIENT"",D SSN^RMPORPT W X;C20;R4;""SSN"",D IT^RMPORPT W X;C27;L30;"""""
19 S FLDS(1)="D QTY^RMPORPT W X;C60;L2;""QTY"",D UCOST^RMPORPT W X;C63;""UNIT COST"",D TCOST^RMPORPT W X;C72;""TOTAL COST"""
20 D SORT
21 D EN1^DIP
22 I RMPORPT=0,$G(RMEND) K DIR S DIR(0)="E" D ^DIR
23EXIT ;
24 ;K SPACE,RB,COUNT,PAGE,RMPOF,RPTDT,^TMP($J,"RMPORPT")
25 ;K FRMDT,TODT,Y,VA,VADM,DFN,RCOST,RNAM,XIOSL,UCOST
26 K ^TMP($J) N RMPR,RMPRSITE D KILL^XUSCLEAN
27 Q
28CNT ;COUNT NAMES
29 I X'="" S COUNT=COUNT+1
30 Q
31PBREAK ;Print the break of primary items.
32 D IT^RMPORPT
33 I PBREAK'=NBREAK W !,"Primary Item: ",PBREAK,! S NBREAK=PBREAK
34 Q
35 ;
36SSN ;GET SSN
37 S X=""
38 K VA,VADM S DFN=D0 D ^VADPT
39 S RNAM=$E(VADM(1),1,22)_"^"_$P(VA("PID"),"-",3)
40 S X=$P(VA("PID"),"-",3)
41 D CNT
42 Q
43IT ;Get the primary Item.
44 S (X,UCOST,QTY)="" N RR,RA S (RR,RA)=0
45 F S RA=$O(^RMPR(665,D0,"RMPOC",RA)) Q:RA="" I $P($G(^RMPR(665,D0,"RMPOC",RA,0)),U,11)="Y" D Q
46 . ; PROSTHETICS PATIENT FILE
47 . S RR=$P(^RMPR(665,D0,"RMPOC",RA,0),U)
48 . S UCOST=$P(^RMPR(665,D0,"RMPOC",RA,0),U,4)
49 . S QTY=$P(^RMPR(665,D0,"RMPOC",RA,0),U,3)
50 . ;PROS ITEM FILE
51 . S RR=$P(^RMPR(661,RR,0),U)
52 . ; ITEM MASTER FILE
53 . S RR=$P(^PRC(441,RR,0),"^",2)
54 . S X=$E(RR,1,30)
55 . S PBREAK=X
56 Q
57 ;
58QTY ;Get the quntity of the primary item.
59 S X=""
60 S X=QTY
61 Q
62 ;
63UCOST ;Get the unit cost of the primary item.
64 S X=""
65 S X=$J(UCOST,7,2)
66 Q
67 ;
68TCOST ;Calculate the total cost of the primary item.
69 S X=""
70 S X=QTY*UCOST,X=$J(X,8,2)
71 Q
72 ;
73ZPAGE(RY) ;Print page.
74 I ($Y+RY)<IOSL Q
75 S RKO="ZL DIO2 X ^TMP($J,1) ZL RMPORPT" X RKO K RKO
76 Q
77 ;
78RPTHDR ;Report header.
79 N RA S RA=RMPO("NAME"),PAGE=PAGE+1
80 W RPTDT,?(40-($L(RA)/2)),RA,?72,"Page: "_PAGE
81 W !?23,"Primary Item Report",!
82 W !?64,"Unit",?73,"Total"
83 W !,"Patient",?20,"SSN",?26,"Primary Item",?58,"Qty"
84 W ?64,"Cost",?74,"Cost"
85 W !,"=================",?19,"====",?26,"=============================="
86 W ?58,"===",?64,"======",?73,"======"
87 W !
88 Q
89 ;
90SORT ;Sort patient by primary item and patient name.
91 N D0,X,Y,UCOST,QTY,PBREAK
92 S (X,Y,UCOST,QTY,PBREAK)=""
93 S D2=0
94ST F S D2=$O(^RMPR(665,"AHO",D2)) Q:D2="" D
95 .S D0="" F S D0=$O(^RMPR(665,"AHO",D2,D0)) Q:D0="" D
96 ..S DFN=$P($G(^RMPR(665,D0,0)),U,1)
97 ..K VADM D ^VADPT S Y=VADM(1)
98 ..D IT S:X'="" ^TMP($J,X,Y,D0)=""
99 Q
100 ;
Note: See TracBrowser for help on using the repository browser.