| 1 | RMPRN7 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;9/16/02 11:35
|
---|
| 2 | ;;3.0;PROSTHETICS;**57,70,90**;Feb 09, 1996
|
---|
| 3 | D DIV4^RMPRSIT G:$D(X) EXIT
|
---|
| 4 | DATE S %DT="XEA",%DT("A")="Enter Date to Start NPPD Calculations From: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT
|
---|
| 5 | S DATE(1)=+Y
|
---|
| 6 | S %DT="XEA",%DT("A")="Enter End Date: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT S DATE(2)=+Y
|
---|
| 7 | I DATE(1)>DATE(2) W !!,$C(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",! G DATE
|
---|
| 8 | Q:$D(RMPRCDE)
|
---|
| 9 | DET ;select detail or brief
|
---|
| 10 | D DISP^RMPRN7S
|
---|
| 11 | K DIR
|
---|
| 12 | S DIR(0)="S^D:DETAIL;B:BRIEF"
|
---|
| 13 | S DIR("A")="Type of Report",DIR("B")="DETAIL" D ^DIR
|
---|
| 14 | Q:$D(DIRUT)!($D(DTOUT))
|
---|
| 15 | S RMPRDET=Y
|
---|
| 16 | DEV ;device
|
---|
| 17 | S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRT
|
---|
| 18 | I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
|
---|
| 19 | I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")=""
|
---|
| 20 | I S ZTRTN="PRT^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
|
---|
| 21 | PRT ;print
|
---|
| 22 | I '$D(IO("Q")) U IO
|
---|
| 23 | D GNP,GNPC
|
---|
| 24 | Q
|
---|
| 25 | ENL ;entry point for one line
|
---|
| 26 | D DIV4^RMPRSIT G:$D(X) EXIT
|
---|
| 27 | S RMPRCDE=1
|
---|
| 28 | D DATE
|
---|
| 29 | G:'$D(DATE(1))!('$D(DATE(2))) EXIT
|
---|
| 30 | ;single line always new and used (BOTH) sort
|
---|
| 31 | S RMPRDET="D"
|
---|
| 32 | D GNPCC,EXIT
|
---|
| 33 | Q
|
---|
| 34 | GNP ;gather nppd data
|
---|
| 35 | S $P(LN,"-",IOM)=""
|
---|
| 36 | S DATE=DATE(1)-1
|
---|
| 37 | K ^TMP($J)
|
---|
| 38 | F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE(2)) D
|
---|
| 39 | .S RMPRB=0
|
---|
| 40 | .F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB'>0 D
|
---|
| 41 | ..;define variables for record
|
---|
| 42 | ..S REC=$G(^RMPR(660,RMPRB,0)) Q:REC=""
|
---|
| 43 | ..Q:$P(REC,U,15)["*"
|
---|
| 44 | ..Q:$P(REC,U,10)'=RMPR("STA")
|
---|
| 45 | ..;check for used pip
|
---|
| 46 | ..;if not LAB, quit
|
---|
| 47 | ..I $P(REC,U,13)'=15&($P(REC,U,13)'=4) Q
|
---|
| 48 | ..S TYPE=$P(REC,U,4)
|
---|
| 49 | ..S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
|
---|
| 50 | ..S MR=$P($G(^RMPR(660,RMPRB,1)),U,4)
|
---|
| 51 | ..I $P(^RMPR(660,RMPRB,0),U,17)'=""&($P(^(0),U,26)="") S TY=2,LINE="R90 A",MR=2676
|
---|
| 52 | ..;PICKUP AND DELIVERY
|
---|
| 53 | ..I $P(^RMPR(660,RMPRB,0),U,26)'="" S TY=2,LINE="R80 D",MR=2951
|
---|
| 54 | ..Q:MR=""
|
---|
| 55 | ..; PATCH 70 Auto-fix
|
---|
| 56 | ..K LINE
|
---|
| 57 | ..I TY'=2 S LINE=$P(^RMPR(661.1,MR,0),U,7)
|
---|
| 58 | ..I TY'=2&($G(LINE)="") D
|
---|
| 59 | ...I TYPE=5 Q
|
---|
| 60 | ...S ERR=""
|
---|
| 61 | ...S LINE=$P(^RMPR(661.1,MR,0),U,6)
|
---|
| 62 | ...S TYPE="X"
|
---|
| 63 | ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
|
---|
| 64 | ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
|
---|
| 65 | ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
|
---|
| 66 | ...K DIE,DA,DR
|
---|
| 67 | ...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
|
---|
| 68 | ...S ^TMP($J,RMPRB)="NEW TO REPAIR"
|
---|
| 69 | ...S B=RMPRB D DATA^RMPRN6XM
|
---|
| 70 | ..I TY=2 S LINE=$P(^RMPR(661.1,MR,0),U,6)
|
---|
| 71 | ..I TY=2&($G(LINE)="") D
|
---|
| 72 | ...I TYPE=5 Q
|
---|
| 73 | ...S ERR=""
|
---|
| 74 | ...S LINE=$P(^RMPR(661.1,MR,0),U,7)
|
---|
| 75 | ...S TYPE="I"
|
---|
| 76 | ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
|
---|
| 77 | ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
|
---|
| 78 | ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
|
---|
| 79 | ...K DIE,DA,DR
|
---|
| 80 | ...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
|
---|
| 81 | ...S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
|
---|
| 82 | ...S B=RMPRB D DATA^RMPRN6XM
|
---|
| 83 | ..;
|
---|
| 84 | ..;set to 999 group if null
|
---|
| 85 | ..S FLAG=$P(^RMPR(661.1,MR,0),U,8)
|
---|
| 86 | ..I FLAG="" S FLAG=2
|
---|
| 87 | ..S CATEGRY=$P($G(^RMPR(660,RMPRB,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P($G(^("AMS")),U,1)
|
---|
| 88 | ..Q:GN=""
|
---|
| 89 | ..D SET
|
---|
| 90 | D FMT^RMPRN6XM,MAIL^RMPRN6XM
|
---|
| 91 | Q
|
---|
| 92 | GNPC ;worksheet/detail
|
---|
| 93 | S STN=RMPR("NAME")
|
---|
| 94 | D CAL^RMPRN7
|
---|
| 95 | S PAGE=0,FL=""
|
---|
| 96 | D ^RMPRN7PT
|
---|
| 97 | G:FL=1 EXIT
|
---|
| 98 | D ^RMPRN7PR
|
---|
| 99 | G:FL=1 EXIT
|
---|
| 100 | I RMPRDET'="D" G EXIT
|
---|
| 101 | D DESP^RMPRN73
|
---|
| 102 | D DESPR^RMPRN73
|
---|
| 103 | EXIT ;commom exit point
|
---|
| 104 | K ^TMP($J) D KILL^XUSCLEAN
|
---|
| 105 | D ^%ZISC
|
---|
| 106 | Q
|
---|
| 107 | GNPCC ;one line only
|
---|
| 108 | S STN=RMPR("NAME")
|
---|
| 109 | D CODE^RMPRN73
|
---|
| 110 | D ^RMPRN7UT
|
---|
| 111 | G:$D(DIRUT)!($D(DTOUT)) EXIT
|
---|
| 112 | I $G(RMPRCDE)="" S RMPRCDE="",RMPRCDE=$O(BRA(Y,RMPRCDE))
|
---|
| 113 | S Y=DATE(1) D DD^%DT S DATE(3)=Y,Y=DATE(2) D DD^%DT S DATE(4)=Y
|
---|
| 114 | S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRTL
|
---|
| 115 | I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
|
---|
| 116 | I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")="",ZTSAVE("RMPRCDE")=""
|
---|
| 117 | I S ZTRTN="PRTL^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
|
---|
| 118 | PRTL ;print one line entry from taskman
|
---|
| 119 | I '$D(IO("Q")) U IO
|
---|
| 120 | D GNP
|
---|
| 121 | D CAL^RMPRN7
|
---|
| 122 | S PAGE=0,FL=""
|
---|
| 123 | S CODE=RMPRCDE
|
---|
| 124 | D DESP^RMPRN7PL
|
---|
| 125 | Q
|
---|
| 126 | SET ;set temp global
|
---|
| 127 | S STN=RMPR("NAME")
|
---|
| 128 | S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE_"L",RMPRB)=""
|
---|
| 129 | S RMSSN=$P(^RMPR(660,RMPRB,0),U,2) I RMSSN S RMSSN=$P(^DPT(RMSSN,0),U,9)
|
---|
| 130 | I RMSSN'="" S ^TMP($J,"A",RMSSN)=""
|
---|
| 131 | K RMSSN
|
---|
| 132 | Q
|
---|
| 133 | ;
|
---|
| 134 | LOOP ;sort on hcpcs key and grouper is complete
|
---|
| 135 | ;store in tmp($j,"N",station) or "R"
|
---|
| 136 | S (TAM,T1,RMPRB,COUNT,CODE,RMPRAD,DATE,RMPRFG,RMPRT,RMPRI,RMPRNW,RMPRRPR)=0
|
---|
| 137 | S (TQTY,RMPROTH,CC,RMPRC,RMPRN,TT,RMPRPSC,VA,CM,RMPRCT1,SO,SI,DIS,RMPRCT,RMPR21,CODE,RMPRB,FM,LEG,RMPRNI,RMPRNO,RMPRSL,RMPRAA,RMPRPHC)=0
|
---|
| 138 | S DATE=DATE(1),RMPRB=0
|
---|
| 139 | CAL ;loop through grouper key sort
|
---|
| 140 | S STN=RMPR("NAME")
|
---|
| 141 | D CODE^RMPRN73
|
---|
| 142 | S GN=""
|
---|
| 143 | F S GN=$O(^TMP($J,"RMPRGN",STN,GN)) Q:GN="" D
|
---|
| 144 | .S FLG=0
|
---|
| 145 | .F S FLG=$O(^TMP($J,"RMPRGN",STN,GN,FLG)) Q:FLG'>0 D I FLG=1&(RMPRDET'=2)!(RMPRDET'=5) Q
|
---|
| 146 | ..;used items never get grouped
|
---|
| 147 | ..I FLG=1&(RMPRDET'=2)&(RMPRDET'=5) D GROUP Q
|
---|
| 148 | ..;I FLG=1 D GROUP Q
|
---|
| 149 | ..S CODE=0
|
---|
| 150 | ..F S CODE=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE)) Q:CODE="" D
|
---|
| 151 | ...S RD=0
|
---|
| 152 | ...F S RD=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)) Q:RD'>0 D
|
---|
| 153 | ....D SORT Q
|
---|
| 154 | Q
|
---|
| 155 | GROUP ;total grouper to main key
|
---|
| 156 | M BC=^TMP($J,"RMPRGN",STN,GN)
|
---|
| 157 | S BF=0,BTCOST=0,SRD=""
|
---|
| 158 | ;bc array is entrie PO 2421
|
---|
| 159 | F S BF=$O(BC(BF)) Q:BF'>0 D
|
---|
| 160 | .;b1 is line,or code
|
---|
| 161 | .S BL=0
|
---|
| 162 | .F S BL=$O(BC(BF,BL)) Q:BL="" D
|
---|
| 163 | ..S BR=0
|
---|
| 164 | ..;BR is record number
|
---|
| 165 | ..F S BR=$O(BC(BF,BL,BR)) Q:BR'>0 D
|
---|
| 166 | ...S BCOST=$P(^RMPR(660,BR,"LB"),U,9)
|
---|
| 167 | ...S BTCOST=BTCOST+BCOST
|
---|
| 168 | ...I (BF=1)&(SRD="") S SRD=BR,CODE="",CODE=$O(BC(1,CODE))
|
---|
| 169 | K BC
|
---|
| 170 | Q:SRD=""
|
---|
| 171 | ;calculate based on primary
|
---|
| 172 | S TYPE=$P(^RMPR(660,SRD,0),U,4)
|
---|
| 173 | S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
|
---|
| 174 | S SOURCE=$P(^RMPR(660,SRD,0),U,14)
|
---|
| 175 | S COST=BTCOST
|
---|
| 176 | ;stock issue display and calculate zero used cost if VA source
|
---|
| 177 | ;I $P(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V") S BTCOST=0,COST=0
|
---|
| 178 | ;I $P(^RMPR(660,SRD,0),U,13)["-3" S COST=0,SOURCE="VA",BTCOST=0
|
---|
| 179 | S QTY=$P(^RMPR(660,SRD,0),U,7)
|
---|
| 180 | S ^TMP($J,CODE,SRD)=COST
|
---|
| 181 | S CATEGRY=$P($G(^RMPR(660,SRD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
|
---|
| 182 | ;new or repair code
|
---|
| 183 | S B1=SRD
|
---|
| 184 | I TY=2 D REP
|
---|
| 185 | I TY'=2 D NEW
|
---|
| 186 | Q
|
---|
| 187 | SORT ;main data for worksheets
|
---|
| 188 | S TYPE=$P(^RMPR(660,RD,0),U,4)
|
---|
| 189 | S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
|
---|
| 190 | S SOURCE=$P(^RMPR(660,RD,0),U,14)
|
---|
| 191 | I SOURCE="" S SOURCE="C"
|
---|
| 192 | S CATEGRY=$P($G(^RMPR(660,RD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
|
---|
| 193 | S COST=$P(^RMPR(660,RD,"LB"),U,9)
|
---|
| 194 | ;stock issue source VA, used cost calculation is zero
|
---|
| 195 | ;I $P(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V") S COST=0
|
---|
| 196 | ;form
|
---|
| 197 | S FORM=$P(^RMPR(660,RD,0),U,13)
|
---|
| 198 | ;I (FORM=4)!(FORM=15) S COST=0,SOURCE="V"
|
---|
| 199 | S QTY=$P(^RMPR(660,RD,0),U,7)
|
---|
| 200 | S B1=RD
|
---|
| 201 | S ^TMP($J,CODE,RD)=COST
|
---|
| 202 | I TY=2 D REP
|
---|
| 203 | I TY'=2 D NEW
|
---|
| 204 | Q
|
---|
| 205 | REP ;calculate repair cost
|
---|
| 206 | ;I $G(RD)'="" D
|
---|
| 207 | ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
|
---|
| 208 | ;.I SSN'="" S ^TMP($J,"A",SSN)=""
|
---|
| 209 | ;.K SSN
|
---|
| 210 | S LINE=CODE
|
---|
| 211 | I LINE="R90 A" S SOURCE="C",QTY=1
|
---|
| 212 | I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
|
---|
| 213 | I SOURCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
|
---|
| 214 | I SOURCE["C" S $P(^TMP($J,"R",STN,LINE),U,2)=$P(^TMP($J,"R",STN,LINE),U,2)+QTY
|
---|
| 215 | ;
|
---|
| 216 | S $P(^TMP($J,"R",STN,LINE),U,3)=$P(^TMP($J,"R",STN,LINE),U,3)+COST
|
---|
| 217 | I CATEGRY=1 S $P(^TMP($J,"R",STN,LINE),U,4)=$P(^TMP($J,"R",STN,LINE),U,4)+1
|
---|
| 218 | I CATEGRY=4 S $P(^TMP($J,"R",STN,LINE),U,5)=$P(^TMP($J,"R",STN,LINE),U,5)+1
|
---|
| 219 | I CATEGRY=2 S $P(^TMP($J,"R",STN,LINE),U,6)=$P(^TMP($J,"R",STN,LINE),U,6)+1
|
---|
| 220 | I CATEGRY=3 S $P(^TMP($J,"R",STN,LINE),U,7)=$P(^TMP($J,"R",STN,LINE),U,7)+1
|
---|
| 221 | I SPEC=1 S $P(^TMP($J,"R",STN,LINE),U,8)=$P(^TMP($J,"R",STN,LINE),U,8)+1
|
---|
| 222 | I SPEC=2 S $P(^TMP($J,"R",STN,LINE),U,9)=$P(^TMP($J,"R",STN,LINE),U,9)+1
|
---|
| 223 | I SPEC=3 S $P(^TMP($J,"R",STN,LINE),U,10)=$P(^TMP($J,"R",STN,LINE),U,10)+1
|
---|
| 224 | I SPEC=4 S $P(^TMP($J,"R",STN,LINE),U,11)=$P(^TMP($J,"R",STN,LINE),U,11)+1,$P(^(LINE),U,16)=$P(^(LINE),U,16)+COST
|
---|
| 225 | I TYPE="I" S $P(^TMP($J,"R",STN,LINE),U,12)=$P(^TMP($J,"R",STN,LINE),U,12)+1
|
---|
| 226 | Q
|
---|
| 227 | ;
|
---|
| 228 | NEW ;calculate new costs
|
---|
| 229 | ;I $G(RD)'="" D
|
---|
| 230 | ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
|
---|
| 231 | ;.I SSN'="" S ^TMP($J,"A",SSN)=""
|
---|
| 232 | ;.K SSN
|
---|
| 233 | S LINE=CODE
|
---|
| 234 | I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
|
---|
| 235 | I SOURCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
|
---|
| 236 | I SOURCE["C" S $P(^TMP($J,"N",STN,LINE),U,2)=$P(^TMP($J,"N",STN,LINE),U,2)+QTY
|
---|
| 237 | S $P(^TMP($J,"N",STN,LINE),U,3)=$P(^TMP($J,"N",STN,LINE),U,3)+COST
|
---|
| 238 | I CATEGRY=1 S $P(^TMP($J,"N",STN,LINE),U,4)=$P(^TMP($J,"N",STN,LINE),U,4)+1
|
---|
| 239 | I CATEGRY=4 S $P(^TMP($J,"N",STN,LINE),U,5)=$P(^TMP($J,"N",STN,LINE),U,5)+1
|
---|
| 240 | I CATEGRY=2 S $P(^TMP($J,"N",STN,LINE),U,6)=$P(^TMP($J,"N",STN,LINE),U,6)+1
|
---|
| 241 | I CATEGRY=3 S $P(^TMP($J,"N",STN,LINE),U,7)=$P(^TMP($J,"N",STN,LINE),U,7)+1
|
---|
| 242 | I SPEC=1 S $P(^TMP($J,"N",STN,LINE),U,8)=$P(^TMP($J,"N",STN,LINE),U,8)+1
|
---|
| 243 | I SPEC=2 S $P(^TMP($J,"N",STN,LINE),U,9)=$P(^TMP($J,"N",STN,LINE),U,9)+1
|
---|
| 244 | I SPEC=3 S $P(^TMP($J,"N",STN,LINE),U,10)=$P(^TMP($J,"N",STN,LINE),U,10)+1
|
---|
| 245 | I SPEC=4 S $P(^TMP($J,"N",STN,LINE),U,11)=$P(^TMP($J,"N",STN,LINE),U,11)+1,$P(^(LINE),U,16)=$P(^(LINE),U,16)+COST
|
---|
| 246 | I TYPE="I" S $P(^TMP($J,"N",STN,LINE),U,12)=$P(^TMP($J,"N",STN,LINE),U,12)+1
|
---|
| 247 | Q
|
---|