source: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXAPRO.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1ECXAPRO ;ALB/JAP - PRO Extract Audit Report ; Nov 16, 1998
2 ;;3.0;DSS EXTRACTS;**9,21,33,36**;Dec 22, 1997
3 ;
4EN ;entry point for PRO extract audit report
5 N %X,%Y,DIV,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT
6 S ECXERR=0
7 ;ecxaud=0 for 'extract' audit
8 S ECXHEAD="PRO",ECXAUD=0
9 W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
10 ;determine primary division
11 S ECXPRIME=$$PDIV^ECXPUTL
12 I ECXPRIME=0 D ^ECXKILL Q
13 S DA=ECXPRIME,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1
14 S ECXPRIME=ECXPRIME_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
15 ;select 1 or more prosthetics divisions for report
16 D PRO^ECXDVSN2(DUZ,ECXPRIME,.ECXDIV,.ECXALL,.ECXERR)
17 I ECXERR D Q
18 .D ^ECXKILL W !!,?5,"Try again later... exiting.",!
19 ;select extract
20 D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
21 I ECXERR=1 D Q
22 .W !!,?5,"Try again later... exiting.",!
23 .D AUDIT^ECXKILL
24 ;if user's selected division doesn't match extract's division, then quit
25 I +ECXPRIME'=ECXARRAY("DIV") D Q
26 .S DIV=+ECXARRAY("DIV") S:$D(^DIC(4,DIV,0)) DIV=$P(^(0),U,1)
27 .W !!,?5,"Your primary division ("_$P(ECXPRIME,U,3)_") does not match the"
28 .W !,?5,"division ("_DIV_") associated with Extract #"_ECXARRAY("EXTRACT")_"."
29 .W !!,?5,"Try again... exiting.",!
30 .I $E(IOST)="C" D
31 ..S SS=20-$Y F JJ=1:1:SS W !
32 ..S DIR(0)="E" W ! D ^DIR K DIR
33 ..W @IOF
34 ;select summary or detail
35 K DIR S DIR(0)="S^D:DETAIL;S:SUMMARY",DIR("A")="Type of Report",DIR("B")="SUMMARY"
36 D ^DIR K DIR
37 I $D(DIRUT)!($D(DTOUT)) D Q
38 .W !!,?5,"Try again later... exiting.",!
39 .D AUDIT^ECXKILL
40 S ECXREPT=Y
41 ;continue with detail report
42 I ECXREPT="D" D
43 .F D ASK2^ECXAPRO2 Q:$D(DIRUT)!($D(DTOUT))
44 ;continue with summary report
45 I ECXREPT="S" D
46 .S ECXPGM="TASK^ECXAPRO",ECXDESC="PRO Extract Audit Report"
47 .S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXREPT")="",ECXSAVE("ECXPRIME")="",ECXSAVE("ECXALL")=""
48 .W !
49 .;determine output device and queue if requested
50 .D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) I ECXSAVE("POP")=1 D Q
51 ..W !!,?5,"Try again later... exiting.",!
52 ..D AUDIT^ECXKILL
53 .I ECXSAVE("ZTSK")=0 D
54 ..K ECXSAVE,ECXPGM,ECXDESC
55 ..D PROCESS,DISP^ECXAPRO1
56 ..;allow user to get details
57 ..D ASK^ECXAPRO2
58 ;clean-up and close
59 I IO'=IO(0) D ^%ZISC
60 D HOME^%ZIS
61 D AUDIT^ECXKILL
62 Q
63 ;
64TASK ;entry point from taskmanager
65 D PROCESS
66 I ECXREPT="S" D DISP^ECXAPRO1
67 I ECXREPT="D" D DISP^ECXAPRO2
68 D AUDIT^ECXKILL
69 Q
70 ;
71PROCESS ;process the data in file #727.826
72 N J,CNT,CODE,COST,CPTNM,DATE,DESC,FLG,GN,IEN,KEY,LOC,LABLC,LABMC,NODE,PTNAM,PSASNM,QTY,QFLG,QQFLG,RD,SSN,STN,SRCE,TYPE
73 K ^TMP($J)
74 S (CNT,QQFLG)=0
75 S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
76 S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
77 D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
78 I ECXALL=0 S J=$O(ECXDIV(99),-1),ECXDIV=ECXDIV(J)
79 I ECXALL=1 S ECXDIV=ECXPRIME
80 S STN=$P(ECXDIV,U,2)
81 ;initialize the prosthetics tmp global for cumulative data
82 D CODE^ECXAPRO1
83 ;gather extract data and sort by grouper number, calc flag, and nppd code
84 S IEN="" F S IEN=$O(^ECX(727.826,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG
85 .S ECXPRO=^ECX(727.826,IEN,0)
86 .;
87 .;- Remove trailing "^" from ECXPRO if there
88 .I $E(ECXPRO,$L(ECXPRO))="^" S ECXPRO=$E(ECXPRO,1,$L(ECXPRO)-1)
89 .S ECXPRO=ECXPRO_U_$P(^ECX(727.826,IEN,1),U,4)
90 .S DATE=$P(ECXPRO,U,9)
91 .S $E(DATE,1,2)=$E(DATE,1,2)-17
92 .Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND)
93 .S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
94 .S PTNAM=$P(ECXPRO,U,7),SSN=$E($P(ECXPRO,U,6),6,9)
95 .S LOC=$P(ECXPRO,U,10),KEY=$P(ECXPRO,U,11),QTY=$P(ECXPRO,U,12)
96 .S COST=$P(ECXPRO,U,25),LABLC=$P(ECXPRO,U,26),LABMC=$P(ECXPRO,U,27)
97 .S GN=$P(ECXPRO,U,34),GN=$S(GN="":" ",1:GN)
98 .;don't double count lab items
99 .Q:LOC["LAB"
100 .;duplicate the logic in sort^rmprn6 that sets cost=0 if form=4
101 .I LOC["ORD" S COST=0
102 .S LOC=$S(LOC["ORD":$P(LOC,"ORD",1),1:$P(LOC,"NONL",1))
103 .;quit if feeder location isn't for division selected for report
104 .I ECXALL=1,LOC'[STN Q
105 .I ECXALL=0,LOC'=STN Q
106 .S TYPE=$E(KEY,6),SRCE=$E(KEY,7)
107 .S CPTNM=$P(ECXPRO,U,15),PSASNM=$P(ECXPRO,U,33)
108 .D GETCODE(PSASNM,.NODE)
109 .Q:NODE=""
110 .S CODE=$S(TYPE="X":$P(NODE,U,3),1:$P(NODE,U,4))
111 .S FLG=$P(NODE,U,2),DESC=$P(NODE,U,5)
112 .S ^TMP($J,"RMPRGN",STN,GN,FLG,CODE,IEN)=TYPE_U_SRCE_U_QTY_U_COST_U_LABLC_U_LABMC_U_PSASNM_U_DESC_U_PTNAM_U_SSN_U_DATE_U_LOC
113 ;accumulate summary & detail data
114 S GN=""
115 F S GN=$O(^TMP($J,"RMPRGN",STN,GN)) Q:GN="" D
116 .S FLG=0
117 .F S FLG=$O(^TMP($J,"RMPRGN",STN,GN,FLG)) Q:FLG'>0 D
118 ..I FLG=1 D GROUP S FLG=2 Q
119 ..S CODE=0
120 ..F S CODE=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE)) Q:CODE="" D
121 ...S RD=0
122 ...F S RD=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)) Q:RD'>0 D
123 ....S TYPE=$P(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD),U,1),SRCE=$P(^(RD),U,2),QTY=$P(^(RD),U,3),COST=$P(^(RD),U,4)
124 ....S ^TMP($J,CODE,RD)=^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)
125 ....I TYPE="X" D REP(CODE)
126 ....I TYPE="N" D NEW(CODE)
127 Q
128 ;
129GETCODE(PSAS,NODE) ;find the appropriate nppd code using psas hcpcs
130 N DIC,X,Y,DESC,FLG,NU,REP
131 S NODE=""
132 S DIC="^RMPR(661.1,",DIC(0)="XZ",X=PSAS D ^DIC
133 I Y=-1 S NODE=U_"2"_U_"R99 Z"_U_"999 Z"_U_"NO HCPCS" Q
134 S DESC=$E($P(Y(0),U,2),1,20)
135 S FLG=$P(Y(0),U,8) S:FLG="" FLG=2
136 ;make sure each code at least 4 characters; group codes are 3 characters in tmp($j,rmprcode)
137 S REP=$P(Y(0),U,6) S:$L(REP)=3 REP=REP_" " S:REP="" REP="R99 X"
138 S NU=$P(Y(0),U,7) S:$L(NU)=3 NU=NU_" " S:NU="" NU="999 X"
139 S NODE=U_FLG_U_REP_U_NU_U_DESC
140 Q
141 ;
142GROUP ;total grouper to main key
143 N BF,BL,BR,BCOST,BTCOST,COST,QTY,TYPE,SRCE
144 S BF=0,BTCOST=0
145 F S BF=$O(^TMP($J,"RMPRGN",STN,GN,BF)) Q:BF'>0 D
146 .S BL=0
147 .F S BL=$O(^TMP($J,"RMPRGN",STN,GN,BF,BL)) Q:BL="" D
148 ..S BR=0
149 ..F S BR=$O(^TMP($J,"RMPRGN",STN,GN,BF,BL,BR)) Q:BR'>0 D
150 ...S BCOST=$P(^TMP($J,"RMPRGN",STN,GN,BF,BL,BR),U,4)
151 ...S BTCOST=BTCOST+BCOST
152 S BL=$O(^TMP($J,"RMPRGN",STN,GN,1,"")),BR=$O(^TMP($J,"RMPRGN",STN,GN,1,BL,""))
153 ;calculate based on primary
154 S TYPE=$P(^TMP($J,"RMPRGN",STN,GN,1,BL,BR),U,1),SRCE=$P(^(BR),U,2),QTY=$P(^(BR),U,3)
155 S COST=BTCOST
156 S ^TMP($J,BL,BR)=^TMP($J,"RMPRGN",STN,GN,1,BL,BR),$P(^TMP($J,BL,BR),U,4)=COST
157 I TYPE="X" D REP(BL)
158 I TYPE="N" D NEW(BL)
159 Q
160 ;
161REP(C) ;calculate repair cost
162 N LINE
163 S LINE=C
164 I LINE="R90 A" S SRCE="C",QTY=1
165 I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
166 I SRCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
167 I SRCE["C" S $P(^TMP($J,"R",STN,LINE),U,2)=$P(^TMP($J,"R",STN,LINE),U,2)+QTY
168 S $P(^TMP($J,"R",STN,LINE),U,3)=$P(^TMP($J,"R",STN,LINE),U,3)+COST
169 Q
170 ;
171NEW(C) ;calculate new costs
172 N LINE
173 S LINE=C
174 I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
175 I SRCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
176 I SRCE["C" S $P(^TMP($J,"N",STN,LINE),U,2)=$P(^TMP($J,"N",STN,LINE),U,2)+QTY
177 S $P(^TMP($J,"N",STN,LINE),U,3)=$P(^TMP($J,"N",STN,LINE),U,3)+COST
178 Q
Note: See TracBrowser for help on using the repository browser.