source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRN6PT.m@ 1093

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RMPRN6PT ;HINES/HNC -PRINT NPPD NEW WORKSHEETS ;2/14/98
2 ;;3.0;PROSTHETICS;**31,32,39,51,57,84,103**;Feb 09, 1996
3 ;
4 ; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines
5 ; AAC Patch 84, 02-25-04, Change Description for 600
6 ; AAC PATCH 103, 01-17-05 NPPD CATEGORIES/LINES - NEW and REPAIR
7 ;
8 K ^TMP($J,"NS")
9 S STN=1
10 S SSNCT=0,BDC=0
11 F S BDC=$O(^TMP($J,"A",BDC)) Q:BDC'>0 S SSNCT=SSNCT+1
12 K BDC,^TMP($J,"A")
13 F S STN=$O(^TMP($J,"N",STN)) Q:STN="" W:$E(IOST,1,2)="C-" @IOF D HDR,CDATA,SUM
14 Q
15HDR ;
16 ;W @IOF
17 W !,"REPORT OF NEW PROSTHETICS ACTIVITIES"
18 ;header based on sort select
19 W !,$$HDR^RMPRN6S(RMPRDET)
20 S Y=DATE(1) D DD^%DT S DATE(3)=Y W !,DATE(3)," - " S Y=DATE(2) D DD^%DT S DATE(4)=Y W DATE(4)
21 W !,?10,"STATION: ",STN
22 ;RMPRSUM if summary header
23 Q:$G(RMPRSUM)
24 W !!
25 W !,"Line",?6,"Item",?21,"VA",?26,"Com",?31,"Total",?37,"Cost",?46
26 W "Ave Com",?54
27 W "SC/OP",?61,"NSC/OP",?68,"SC/IP",?74,"NSC/IP"
28 I IOM>120 D
29 .W ?83,"SP LEG"
30 .W ?90,"A&A",?97,"PHC",?104,"ELG REF",?112,"NEW",?120,"$ELG REF"
31 Q
32CDATA ;
33 S LINE="",LINEP=""
34 S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
35 F S LINE=$O(^TMP($J,"N",STN,LINE)) Q:LINE="" Q:FL=1 D
36 .I $E(LINE,0,3)'=$E(LINEP,0,3) D SUM Q:FL=1 D LBL
37 .W !,LINE,?6,$E($P(^TMP($J,"N",STN,LINE),U,15),1,15)
38 .W ?21,$P(^TMP($J,"N",STN,LINE),U,1) S CA=CA+$P(^(LINE),U,1)
39 .W ?26,$P(^TMP($J,"N",STN,LINE),U,2) S CB=CB+$P(^(LINE),U,2)
40 .W ?31,$P(^TMP($J,"N",STN,LINE),U,1)+($P(^TMP($J,"N",STN,LINE),U,2))
41 .W ?37,$FN($J($P(^TMP($J,"N",STN,LINE),U,3),0,0),",") S CC=CC+$P(^(LINE),U,3)
42 .W:$P(^TMP($J,"N",STN,LINE),U,2)>0 ?46,$FN($J(($P(^(LINE),U,3))/($P(^(LINE),U,2)),0,0),",")
43 .W ?55,$P(^TMP($J,"N",STN,LINE),U,4) S CD=CD+$P(^(LINE),U,4)
44 .W ?62,$P(^TMP($J,"N",STN,LINE),U,5) S CE=CE+$P(^(LINE),U,5)
45 .W ?69,$P(^TMP($J,"N",STN,LINE),U,6) S CF=CF+$P(^(LINE),U,6)
46 .W ?76,$P(^TMP($J,"N",STN,LINE),U,7) S CG=CG+$P(^(LINE),U,7)
47 .S CH=CH+$P(^TMP($J,"N",STN,LINE),U,8)
48 .S CI=CI+$P(^TMP($J,"N",STN,LINE),U,9)
49 .S CJ=CJ+$P(^TMP($J,"N",STN,LINE),U,10)
50 .S CK=CK+$P(^TMP($J,"N",STN,LINE),U,11)
51 .S CL=CL+$P(^TMP($J,"N",STN,LINE),U,12)
52 .S CM=CM+$P(^TMP($J,"N",STN,LINE),U,16)
53 .I IOM>120 D
54 ..W ?83,$P(^TMP($J,"N",STN,LINE),U,8)
55 ..W ?90,$P(^TMP($J,"N",STN,LINE),U,9)
56 ..W ?97,$P(^TMP($J,"N",STN,LINE),U,10)
57 ..W ?104,$P(^TMP($J,"N",STN,LINE),U,11)
58 ..W ?112,$P(^TMP($J,"N",STN,LINE),U,12)
59 ..W ?120,$P(^TMP($J,"N",STN,LINE),U,16)
60 .S LINEP=LINE
61 Q
62SUM ;Print summary for group
63 Q:FL=1
64 I LINEP'="" D Q:FL=1
65 .I $Y+13>IOSL,IOST["C-" D CHK Q:FL=1
66 .S GROUPT=CA_U_CB_U_(CA+CB)_U_$J(CC,0,0)_U_CD_U_CE_U_CF_U_CG_U_CH_U_CI_U_CJ_U_CK_U_CL_U_CM
67 .W !,LN,!
68 .W ?21,CA,?26,CB,?31,(CA+CB),?37,$FN($J(CC,0,0),","),?55,CD,?62,CE,?69,CF,?76,CG
69 .I IOM>120 W ?83,CH,?90,CI,?97,CJ,?104,CK,?112,CL,?120,CM
70 .W !
71 .D LBLG
72 .S ^TMP($J,"NS",STN,GROUP,STN)=GROUPT
73 .S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
74 Q:$G(LINEP)'="999 Z"
75 D FSUM S RMPRSUM=1 W @IOF D HDR K RMPRSUM
76 W !!,"STATION SUMMARY (NEW ACTIVITIES)"
77 ;W !,$$HDR^RMPRN6S(RMPRDET)
78 W !,?21,"VA",?31,"Com",?41,"Total",?51,"Cost",?61
79 W "Ave Com",?71,"Elg Ref $"
80 W !,LN
81 W !,?21,$FN(CA,","),?31,$FN(CB,","),?41,$FN((CA+CB),","),?51,"$"_$FN($J(CC,0,0),",")
82 I CB>0 W ?61,"$"_$FN($J((CC/CB),0,0),",")
83 I CM>0 W ?71,"$"_$FN($J(CM,0,0),",")
84 W !,LN,!!
85 W ?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"
86 W !,LN,!,?21,CD,?31,CE,?41,CF,?51,CG
87 W !,LN
88 W !,?21,"SPEC LEG",?31,"A&A",?41,"PHC",?51,"ELG REF",?61,"NEW"
89 W !,LN,!,?21,CH,?31,CI,?41,CJ,?51,CK,?61,CL,!,LN
90 W !,?21,"Total Disability: ",$FN((CD+CE+CF+CG),","),?47,"Unique SSN: ",SSNCT,!
91 S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
92 I IOST["C-" D CHK
93 Q
94LBLG ;group description for final summary
95 I $E(LINEP,0,3)=100 S GROUP=$E(LINEP,0,3)_" WHEELCHAIRS AND ACCESSORIES"
96 I $E(LINEP,0,3)=200 S GROUP=$E(LINEP,0,3)_" ARTIFICIAL LEGS"
97 I $E(LINEP,0,3)=300 S GROUP=$E(LINEP,0,3)_" ARTIFICIAL ARMS AND TERMINAL DEVICES"
98 I $E(LINEP,0,3)=400 S GROUP=$E(LINEP,0,3)_" ORTHOSIS/ORTHOTICS"
99 I $E(LINEP,0,3)=500 S GROUP=$E(LINEP,0,3)_" SHOES/ORTHOTICS"
100 I $E(LINEP,0,3)=600 S GROUP=$E(LINEP,0,3)_" SENSORI-NEURO AIDS"
101 I $E(LINEP,0,3)=700 S GROUP=$E(LINEP,0,3)_" RESTORATIONS"
102 I $E(LINEP,0,3)=800 S GROUP=$E(LINEP,0,3)_" OXYGEN AND RESPIRATORY"
103 I $E(LINEP,0,3)=900 S GROUP=$E(LINEP,0,3)_" MEDICAL EQUIPMENT"
104 I $E(LINEP,0,3)=910 S GROUP=$E(LINEP,0,3)_" ALL OTHER SUPPLIES AND EQUIPMENT"
105 I $E(LINEP,0,3)=920 S GROUP=$E(LINEP,0,3)_" HOME DIALYSIS PROGRAM"
106 I $E(LINEP,0,3)=930 S GROUP=$E(LINEP,0,3)_" ADAPTIVE EQUIPMENT"
107 I $E(LINEP,0,3)=940 S GROUP=$E(LINEP,0,3)_" HISA"
108 I $E(LINEP,0,3)=960 S GROUP=$E(LINEP,0,3)_" SURGICAL IMPLANTS"
109 I $E(LINEP,0,3)=999 S GROUP=$E(LINEP,0,3)_" MISC"
110 Q
111LBL ;label for group
112 I $E(LINE,0,3)=100 W !,"WHEELCHAIRS AND ACCESSORIES"
113 I $E(LINE,0,3)=200 W !,"ARTIFICIAL LEGS"
114 I $E(LINE,0,3)=300 W !,"ARTIFICIAL ARMS AND TERMINAL DEVICES"
115 I $E(LINE,0,3)=400 W !,"ORTHOSIS/ORTHOTICS"
116 I $E(LINE,0,3)=500,IOST'["C-" W @IOF D HDR W !,"SHOES/ORTHOTICS"
117 I $E(LINE,0,3)=500,IOST["C-" W !,"SHOES/ORTHOTICS"
118 I $E(LINE,0,3)=600 W !,"SENSORI-NEURO AIDS"
119 I $E(LINE,0,3)=700 W !,"RESTORATIONS"
120 I $E(LINE,0,3)=800 W !,"OXYGEN AND RESPIRATORY"
121 I $E(LINE,0,3)=900,IOST'["C-" W @IOF D HDR W !,"MEDICAL EQUIPMENT"
122 I $E(LINE,0,3)=900,IOST["C-" W !,"MEDICAL EQUIPMENT"
123 I $E(LINE,0,3)=910 W !,"ALL OTHER SUPPLIES AND EQUIPMENT"
124 I $E(LINE,0,3)=920 W !,"HOME DIALYSIS PROGRAM"
125 I $E(LINE,0,3)=930 W !,"ADAPTIVE EQUIPMENT"
126 I $E(LINE,0,3)=940 W !,"HISA"
127 I $E(LINE,0,3)=960 W !,"SURGICAL IMPLANTS"
128 I $E(LINE,0,3)=999,IOST'["C-" W @IOF D HDR W !,"MISC"
129 I $E(LINE,0,3)=999,IOST["C-" W !,"MISC"
130 Q
131FSUM ;final summay on New Worksheets STATION
132 S H=0
133 F S H=$O(^TMP($J,"NS",STN,H)) Q:H="" D
134 .S H1=0,H2=0
135 .F S H1=$O(^TMP($J,"NS",STN,H,H1)) Q:H1="" D
136 ..Q:H1'=STN
137 ..S H2=^TMP($J,"NS",STN,H,H1)
138 ..S CA=CA+$P(H2,U,1)
139 ..S CB=CB+$P(H2,U,2)
140 ..S CC=CC+$P(H2,U,4)
141 ..S CD=CD+$P(H2,U,5)
142 ..S CE=CE+$P(H2,U,6)
143 ..S CF=CF+$P(H2,U,7)
144 ..S CG=CG+$P(H2,U,8)
145 ..S CH=CH+$P(H2,U,9)
146 ..S CI=CI+$P(H2,U,10)
147 ..S CJ=CJ+$P(H2,U,11)
148 ..S CK=CK+$P(H2,U,12)
149 ..S CL=CL+$P(H2,U,13)
150 ..S CM=CM+$P(H2,U,14)
151 Q
152CHK ;
153 K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1
154 W @IOF
155 Q
156 ;END
Note: See TracBrowser for help on using the repository browser.