RMPRN7 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;9/16/02 11:35
;;3.0;PROSTHETICS;**57,70,90,144**;Feb 09, 1996;Build 17
D DIV4^RMPRSIT G:$D(X) EXIT
DATE S %DT="XEA",%DT("A")="Enter Date to Start NPPD Calculations From: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT
S DATE(1)=+Y
S %DT="XEA",%DT("A")="Enter End Date: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT S DATE(2)=+Y
I DATE(1)>DATE(2) W !!,$C(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",! G DATE
Q:$D(RMPRCDE)
DET ;select detail or brief
D DISP^RMPRN7S
K DIR
S DIR(0)="S^D:DETAIL;B:BRIEF"
S DIR("A")="Type of Report",DIR("B")="DETAIL" D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S RMPRDET=Y
DEV ;device
S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRT
I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")=""
I S ZTRTN="PRT^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
PRT ;print
I '$D(IO("Q")) U IO
D GNP,GNPC
Q
ENL ;entry point for one line
D DIV4^RMPRSIT G:$D(X) EXIT
S RMPRCDE=1
D DATE
G:'$D(DATE(1))!('$D(DATE(2))) EXIT
;single line always new and used (BOTH) sort
S RMPRDET="D"
D GNPCC,EXIT
Q
GNP ;gather nppd data
S $P(LN,"-",IOM)=""
S DATE=DATE(1)-1
K ^TMP($J)
F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE(2)) D
.S RMPRB=0
.F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB'>0 D
..;define variables for record
..S REC=$G(^RMPR(660,RMPRB,0)) Q:REC=""
..Q:$P(REC,U,15)["*"
..Q:$P(REC,U,10)'=RMPR("STA")
..;check for used pip
..;if not LAB, quit
..I $P(REC,U,13)'=15&($P(REC,U,13)'=4) Q
..S TYPE=$P(REC,U,4)
..S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
..S MR=$P($G(^RMPR(660,RMPRB,1)),U,4)
..I $P(^RMPR(660,RMPRB,0),U,17)'=""&($P(^(0),U,26)="") S TY=2,LINE="R99 A",MR=2676
..;PICKUP AND DELIVERY
..I $P(^RMPR(660,RMPRB,0),U,26)'="" S TY=2,LINE="R80 D",MR=2951
..Q:MR=""
..; PATCH 70 Auto-fix
..K LINE
..I TY'=2 S LINE=$P(^RMPR(661.1,MR,0),U,7)
..I TY'=2&($G(LINE)="") D
...I TYPE=5 Q
...S ERR=""
...S LINE=$P(^RMPR(661.1,MR,0),U,6) S:MR=2676 LINE="R99 A"
...S TYPE="X"
...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
...K DIE,DA,DR
...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
...S ^TMP($J,RMPRB)="NEW TO REPAIR"
...S B=RMPRB D DATA^RMPRN6XM
..I TY=2 S LINE=$P(^RMPR(661.1,MR,0),U,6) S:MR=2676 LINE="R99 A"
..I TY=2&($G(LINE)="") D
...I TYPE=5 Q
...S ERR=""
...S LINE=$P(^RMPR(661.1,MR,0),U,7)
...S TYPE="I"
...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
...K DIE,DA,DR
...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
...S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
...S B=RMPRB D DATA^RMPRN6XM
..;
..;set to 999 group if null
..S FLAG=$P(^RMPR(661.1,MR,0),U,8)
..I FLAG="" S FLAG=2
..S CATEGRY=$P($G(^RMPR(660,RMPRB,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P($G(^("AMS")),U,1)
..Q:GN=""
..D SET
D FMT^RMPRN6XM,MAIL^RMPRN6XM
Q
GNPC ;worksheet/detail
S STN=RMPR("NAME")
D CAL^RMPRN7
S PAGE=0,FL=""
D ^RMPRN7PT
G:FL=1 EXIT
D ^RMPRN7PR
G:FL=1 EXIT
I RMPRDET'="D" G EXIT
D DESP^RMPRN73
D DESPR^RMPRN73
EXIT ;commom exit point
K ^TMP($J) D KILL^XUSCLEAN
D ^%ZISC
Q
GNPCC ;one line only
S STN=RMPR("NAME")
D CODE^RMPRN73
D ^RMPRN7UT
G:$D(DIRUT)!($D(DTOUT)) EXIT
I $G(RMPRCDE)="" S RMPRCDE="",RMPRCDE=$O(BRA(Y,RMPRCDE))
S Y=DATE(1) D DD^%DT S DATE(3)=Y,Y=DATE(2) D DD^%DT S DATE(4)=Y
S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRTL
I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")="",ZTSAVE("RMPRCDE")=""
I S ZTRTN="PRTL^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
PRTL ;print one line entry from taskman
I '$D(IO("Q")) U IO
D GNP
D CAL^RMPRN7
S PAGE=0,FL=""
S CODE=RMPRCDE
D DESP^RMPRN7PL
Q
SET ;set temp global
S STN=RMPR("NAME")
S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE_"L",RMPRB)=""
S RMSSN=$P(^RMPR(660,RMPRB,0),U,2) I RMSSN S RMSSN=$P(^DPT(RMSSN,0),U,9)
I RMSSN'="" S ^TMP($J,"A",RMSSN)=""
K RMSSN
Q
;
LOOP ;sort on hcpcs key and grouper is complete
;store in tmp($j,"N",station) or "R"
S (TAM,T1,RMPRB,COUNT,CODE,RMPRAD,DATE,RMPRFG,RMPRT,RMPRI,RMPRNW,RMPRRPR)=0
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
S DATE=DATE(1),RMPRB=0
CAL ;loop through grouper key sort
S STN=RMPR("NAME")
D CODE^RMPRN73
S GN=""
F S GN=$O(^TMP($J,"RMPRGN",STN,GN)) Q:GN="" D
.S FLG=0
.F S FLG=$O(^TMP($J,"RMPRGN",STN,GN,FLG)) Q:FLG'>0 D I FLG=1&(RMPRDET'=2)!(RMPRDET'=5) Q
..;used items never get grouped
..I FLG=1&(RMPRDET'=2)&(RMPRDET'=5) D GROUP Q
..;I FLG=1 D GROUP Q
..S CODE=0
..F S CODE=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE)) Q:CODE="" D
...S RD=0
...F S RD=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)) Q:RD'>0 D
....D SORT Q
Q
GROUP ;total grouper to main key
M BC=^TMP($J,"RMPRGN",STN,GN)
S BF=0,BTCOST=0,SRD=""
;bc array is entrie PO 2421
F S BF=$O(BC(BF)) Q:BF'>0 D
.;b1 is line,or code
.S BL=0
.F S BL=$O(BC(BF,BL)) Q:BL="" D
..S BR=0
..;BR is record number
..F S BR=$O(BC(BF,BL,BR)) Q:BR'>0 D
...S BCOST=$P(^RMPR(660,BR,"LB"),U,9)
...S BTCOST=BTCOST+BCOST
...I (BF=1)&(SRD="") S SRD=BR,CODE="",CODE=$O(BC(1,CODE))
K BC
Q:SRD=""
;calculate based on primary
S TYPE=$P(^RMPR(660,SRD,0),U,4)
S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
S SOURCE=$P(^RMPR(660,SRD,0),U,14)
S COST=BTCOST
;stock issue display and calculate zero used cost if VA source
;I $P(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V") S BTCOST=0,COST=0
;I $P(^RMPR(660,SRD,0),U,13)["-3" S COST=0,SOURCE="VA",BTCOST=0
S QTY=$P(^RMPR(660,SRD,0),U,7)
S ^TMP($J,CODE,SRD)=COST
S CATEGRY=$P($G(^RMPR(660,SRD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
;new or repair code
S B1=SRD
I TY=2 D REP
I TY'=2 D NEW
Q
SORT ;main data for worksheets
S TYPE=$P(^RMPR(660,RD,0),U,4)
S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
S SOURCE=$P(^RMPR(660,RD,0),U,14)
I SOURCE="" S SOURCE="C"
S CATEGRY=$P($G(^RMPR(660,RD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
S COST=$P(^RMPR(660,RD,"LB"),U,9)
;stock issue source VA, used cost calculation is zero
;I $P(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V") S COST=0
;form
S FORM=$P(^RMPR(660,RD,0),U,13)
;I (FORM=4)!(FORM=15) S COST=0,SOURCE="V"
S QTY=$P(^RMPR(660,RD,0),U,7)
S B1=RD
S ^TMP($J,CODE,RD)=COST
I TY=2 D REP
I TY'=2 D NEW
Q
REP ;calculate repair cost
;I $G(RD)'="" D
;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
;.I SSN'="" S ^TMP($J,"A",SSN)=""
;.K SSN
S LINE=CODE
I LINE="R99 A" S SOURCE="C",QTY=1
I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
I SOURCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
I SOURCE["C" S $P(^TMP($J,"R",STN,LINE),U,2)=$P(^TMP($J,"R",STN,LINE),U,2)+QTY
;
S $P(^TMP($J,"R",STN,LINE),U,3)=$P(^TMP($J,"R",STN,LINE),U,3)+COST
I CATEGRY=1 S $P(^TMP($J,"R",STN,LINE),U,4)=$P(^TMP($J,"R",STN,LINE),U,4)+1
I CATEGRY=4 S $P(^TMP($J,"R",STN,LINE),U,5)=$P(^TMP($J,"R",STN,LINE),U,5)+1
I CATEGRY=2 S $P(^TMP($J,"R",STN,LINE),U,6)=$P(^TMP($J,"R",STN,LINE),U,6)+1
I CATEGRY=3 S $P(^TMP($J,"R",STN,LINE),U,7)=$P(^TMP($J,"R",STN,LINE),U,7)+1
I SPEC=1 S $P(^TMP($J,"R",STN,LINE),U,8)=$P(^TMP($J,"R",STN,LINE),U,8)+1
I SPEC=2 S $P(^TMP($J,"R",STN,LINE),U,9)=$P(^TMP($J,"R",STN,LINE),U,9)+1
I SPEC=3 S $P(^TMP($J,"R",STN,LINE),U,10)=$P(^TMP($J,"R",STN,LINE),U,10)+1
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
I TYPE="I" S $P(^TMP($J,"R",STN,LINE),U,12)=$P(^TMP($J,"R",STN,LINE),U,12)+1
Q
;
NEW ;calculate new costs
;I $G(RD)'="" D
;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
;.I SSN'="" S ^TMP($J,"A",SSN)=""
;.K SSN
S LINE=CODE
I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
I SOURCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
I SOURCE["C" S $P(^TMP($J,"N",STN,LINE),U,2)=$P(^TMP($J,"N",STN,LINE),U,2)+QTY
S $P(^TMP($J,"N",STN,LINE),U,3)=$P(^TMP($J,"N",STN,LINE),U,3)+COST
I CATEGRY=1 S $P(^TMP($J,"N",STN,LINE),U,4)=$P(^TMP($J,"N",STN,LINE),U,4)+1
I CATEGRY=4 S $P(^TMP($J,"N",STN,LINE),U,5)=$P(^TMP($J,"N",STN,LINE),U,5)+1
I CATEGRY=2 S $P(^TMP($J,"N",STN,LINE),U,6)=$P(^TMP($J,"N",STN,LINE),U,6)+1
I CATEGRY=3 S $P(^TMP($J,"N",STN,LINE),U,7)=$P(^TMP($J,"N",STN,LINE),U,7)+1
I SPEC=1 S $P(^TMP($J,"N",STN,LINE),U,8)=$P(^TMP($J,"N",STN,LINE),U,8)+1
I SPEC=2 S $P(^TMP($J,"N",STN,LINE),U,9)=$P(^TMP($J,"N",STN,LINE),U,9)+1
I SPEC=3 S $P(^TMP($J,"N",STN,LINE),U,10)=$P(^TMP($J,"N",STN,LINE),U,10)+1
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
I TYPE="I" S $P(^TMP($J,"N",STN,LINE),U,12)=$P(^TMP($J,"N",STN,LINE),U,12)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRN7 9250 printed Dec 13, 2024@02:35:13 Page 2
RMPRN7 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;9/16/02 11:35
+1 ;;3.0;PROSTHETICS;**57,70,90,144**;Feb 09, 1996;Build 17
+2 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
DATE SET %DT="XEA"
SET %DT("A")="Enter Date to Start NPPD Calculations From: "
DO ^%DT
if X[U!(X="")!($DATA(DTOUT))
GOTO EXIT
+1 SET DATE(1)=+Y
+2 SET %DT="XEA"
SET %DT("A")="Enter End Date: "
DO ^%DT
if X[U!(X="")!($DATA(DTOUT))
GOTO EXIT
SET DATE(2)=+Y
+3 IF DATE(1)>DATE(2)
WRITE !!,$CHAR(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",!
GOTO DATE
+4 if $DATA(RMPRCDE)
QUIT
DET ;select detail or brief
+1 DO DISP^RMPRN7S
+2 KILL DIR
+3 SET DIR(0)="S^D:DETAIL;B:BRIEF"
+4 SET DIR("A")="Type of Report"
SET DIR("B")="DETAIL"
DO ^DIR
+5 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+6 SET RMPRDET=Y
DEV ;device
+1 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
KILL IOP
IF $EXTRACT(IOST,1,2)["C-"
GOTO PRT
+2 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTSAVE("RMPRSITE")=""
SET ZTSAVE("RMPR(")=""
+3 IF $TEST
SET ZTSAVE("DATE(")=""
SET ZTSAVE("RMPRZ")=""
SET ZTSAVE("RMPRDET")=""
+4 IF $TEST
SET ZTRTN="PRT^RMPRN7"
SET ZTDESC="Prosthetic 2529-3 NPPD"
DO ^%ZTLOAD
KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE
GOTO EXIT
PRT ;print
+1 IF '$DATA(IO("Q"))
USE IO
+2 DO GNP
DO GNPC
+3 QUIT
ENL ;entry point for one line
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+2 SET RMPRCDE=1
+3 DO DATE
+4 if '$DATA(DATE(1))!('$DATA(DATE(2)))
GOTO EXIT
+5 ;single line always new and used (BOTH) sort
+6 SET RMPRDET="D"
+7 DO GNPCC
DO EXIT
+8 QUIT
GNP ;gather nppd data
+1 SET $PIECE(LN,"-",IOM)=""
+2 SET DATE=DATE(1)-1
+3 KILL ^TMP($JOB)
+4 FOR
SET DATE=$ORDER(^RMPR(660,"B",DATE))
if (DATE="")!($PIECE(DATE,".",1)>DATE(2))
QUIT
Begin DoDot:1
+5 SET RMPRB=0
+6 FOR
SET RMPRB=$ORDER(^RMPR(660,"B",DATE,RMPRB))
if RMPRB'>0
QUIT
Begin DoDot:2
+7 ;define variables for record
+8 SET REC=$GET(^RMPR(660,RMPRB,0))
if REC=""
QUIT
+9 if $PIECE(REC,U,15)["*"
QUIT
+10 if $PIECE(REC,U,10)'=RMPR("STA")
QUIT
+11 ;check for used pip
+12 ;if not LAB, quit
+13 IF $PIECE(REC,U,13)'=15&($PIECE(REC,U,13)'=4)
QUIT
+14 SET TYPE=$PIECE(REC,U,4)
+15 SET TY=$SELECT(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
+16 SET MR=$PIECE($GET(^RMPR(660,RMPRB,1)),U,4)
+17 IF $PIECE(^RMPR(660,RMPRB,0),U,17)'=""&($PIECE(^(0),U,26)="")
SET TY=2
SET LINE="R99 A"
SET MR=2676
+18 ;PICKUP AND DELIVERY
+19 IF $PIECE(^RMPR(660,RMPRB,0),U,26)'=""
SET TY=2
SET LINE="R80 D"
SET MR=2951
+20 if MR=""
QUIT
+21 ; PATCH 70 Auto-fix
+22 KILL LINE
+23 IF TY'=2
SET LINE=$PIECE(^RMPR(661.1,MR,0),U,7)
+24 IF TY'=2&($GET(LINE)="")
Begin DoDot:3
+25 IF TYPE=5
QUIT
+26 SET ERR=""
+27 SET LINE=$PIECE(^RMPR(661.1,MR,0),U,6)
if MR=2676
SET LINE="R99 A"
+28 SET TYPE="X"
+29 SET DIE="^RMPR(660,"
SET DA=RMPRB
SET DR="2///^S X=TYPE"
+30 LOCK +^RMPR(660,RMPRB):1
IF '$TEST
SET ERR=1
+31 IF ERR=""
DO ^DIE
LOCK -^RMPR(660,RMPRB)
+32 KILL DIE,DA,DR
+33 IF ERR=1
SET ^TMP($JOB,RMPRB)="NO UPDATE!"
+34 SET ^TMP($JOB,RMPRB)="NEW TO REPAIR"
+35 SET B=RMPRB
DO DATA^RMPRN6XM
End DoDot:3
+36 IF TY=2
SET LINE=$PIECE(^RMPR(661.1,MR,0),U,6)
if MR=2676
SET LINE="R99 A"
+37 IF TY=2&($GET(LINE)="")
Begin DoDot:3
+38 IF TYPE=5
QUIT
+39 SET ERR=""
+40 SET LINE=$PIECE(^RMPR(661.1,MR,0),U,7)
+41 SET TYPE="I"
+42 SET DIE="^RMPR(660,"
SET DA=RMPRB
SET DR="2///^S X=TYPE"
+43 LOCK +^RMPR(660,RMPRB):1
IF '$TEST
SET ERR=1
+44 IF ERR=""
DO ^DIE
LOCK -^RMPR(660,RMPRB)
+45 KILL DIE,DA,DR
+46 IF ERR=1
SET ^TMP($JOB,RMPRB)="NO UPDATE!"
+47 SET ^TMP($JOB,"RMPRA",RMPRB)="REPAIR TO NEW"
+48 SET B=RMPRB
DO DATA^RMPRN6XM
End DoDot:3
+49 ;
+50 ;set to 999 group if null
+51 SET FLAG=$PIECE(^RMPR(661.1,MR,0),U,8)
+52 IF FLAG=""
SET FLAG=2
+53 SET CATEGRY=$PIECE($GET(^RMPR(660,RMPRB,"AM")),U,3)
SET SPEC=$PIECE($GET(^("AM")),U,4)
SET GN=$PIECE($GET(^("AMS")),U,1)
+54 if GN=""
QUIT
+55 DO SET
End DoDot:2
End DoDot:1
+56 DO FMT^RMPRN6XM
DO MAIL^RMPRN6XM
+57 QUIT
GNPC ;worksheet/detail
+1 SET STN=RMPR("NAME")
+2 DO CAL^RMPRN7
+3 SET PAGE=0
SET FL=""
+4 DO ^RMPRN7PT
+5 if FL=1
GOTO EXIT
+6 DO ^RMPRN7PR
+7 if FL=1
GOTO EXIT
+8 IF RMPRDET'="D"
GOTO EXIT
+9 DO DESP^RMPRN73
+10 DO DESPR^RMPRN73
EXIT ;commom exit point
+1 KILL ^TMP($JOB)
DO KILL^XUSCLEAN
+2 DO ^%ZISC
+3 QUIT
GNPCC ;one line only
+1 SET STN=RMPR("NAME")
+2 DO CODE^RMPRN73
+3 DO ^RMPRN7UT
+4 if $DATA(DIRUT)!($DATA(DTOUT))
GOTO EXIT
+5 IF $GET(RMPRCDE)=""
SET RMPRCDE=""
SET RMPRCDE=$ORDER(BRA(Y,RMPRCDE))
+6 SET Y=DATE(1)
DO DD^%DT
SET DATE(3)=Y
SET Y=DATE(2)
DO DD^%DT
SET DATE(4)=Y
+7 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
KILL IOP
IF $EXTRACT(IOST,1,2)["C-"
GOTO PRTL
+8 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTSAVE("RMPRSITE")=""
SET ZTSAVE("RMPR(")=""
+9 IF $TEST
SET ZTSAVE("DATE(")=""
SET ZTSAVE("RMPRZ")=""
SET ZTSAVE("RMPRDET")=""
SET ZTSAVE("RMPRCDE")=""
+10 IF $TEST
SET ZTRTN="PRTL^RMPRN7"
SET ZTDESC="Prosthetic 2529-3 NPPD"
DO ^%ZTLOAD
KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE
GOTO EXIT
PRTL ;print one line entry from taskman
+1 IF '$DATA(IO("Q"))
USE IO
+2 DO GNP
+3 DO CAL^RMPRN7
+4 SET PAGE=0
SET FL=""
+5 SET CODE=RMPRCDE
+6 DO DESP^RMPRN7PL
+7 QUIT
SET ;set temp global
+1 SET STN=RMPR("NAME")
+2 SET ^TMP($JOB,"RMPRGN",STN,GN,FLAG,LINE_"L",RMPRB)=""
+3 SET RMSSN=$PIECE(^RMPR(660,RMPRB,0),U,2)
IF RMSSN
SET RMSSN=$PIECE(^DPT(RMSSN,0),U,9)
+4 IF RMSSN'=""
SET ^TMP($JOB,"A",RMSSN)=""
+5 KILL RMSSN
+6 QUIT
+7 ;
LOOP ;sort on hcpcs key and grouper is complete
+1 ;store in tmp($j,"N",station) or "R"
+2 SET (TAM,T1,RMPRB,COUNT,CODE,RMPRAD,DATE,RMPRFG,RMPRT,RMPRI,RMPRNW,RMPRRPR)=0
+3 SET (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
+4 SET DATE=DATE(1)
SET RMPRB=0
CAL ;loop through grouper key sort
+1 SET STN=RMPR("NAME")
+2 DO CODE^RMPRN73
+3 SET GN=""
+4 FOR
SET GN=$ORDER(^TMP($JOB,"RMPRGN",STN,GN))
if GN=""
QUIT
Begin DoDot:1
+5 SET FLG=0
+6 FOR
SET FLG=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG))
if FLG'>0
QUIT
Begin DoDot:2
+7 ;used items never get grouped
+8 IF FLG=1&(RMPRDET'=2)&(RMPRDET'=5)
DO GROUP
QUIT
+9 ;I FLG=1 D GROUP Q
+10 SET CODE=0
+11 FOR
SET CODE=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE))
if CODE=""
QUIT
Begin DoDot:3
+12 SET RD=0
+13 FOR
SET RD=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE,RD))
if RD'>0
QUIT
Begin DoDot:4
+14 DO SORT
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
IF FLG=1&(RMPRDET'=2)!(RMPRDET'=5)
QUIT
End DoDot:1
+15 QUIT
GROUP ;total grouper to main key
+1 MERGE BC=^TMP($JOB,"RMPRGN",STN,GN)
+2 SET BF=0
SET BTCOST=0
SET SRD=""
+3 ;bc array is entrie PO 2421
+4 FOR
SET BF=$ORDER(BC(BF))
if BF'>0
QUIT
Begin DoDot:1
+5 ;b1 is line,or code
+6 SET BL=0
+7 FOR
SET BL=$ORDER(BC(BF,BL))
if BL=""
QUIT
Begin DoDot:2
+8 SET BR=0
+9 ;BR is record number
+10 FOR
SET BR=$ORDER(BC(BF,BL,BR))
if BR'>0
QUIT
Begin DoDot:3
+11 SET BCOST=$PIECE(^RMPR(660,BR,"LB"),U,9)
+12 SET BTCOST=BTCOST+BCOST
+13 IF (BF=1)&(SRD="")
SET SRD=BR
SET CODE=""
SET CODE=$ORDER(BC(1,CODE))
End DoDot:3
End DoDot:2
End DoDot:1
+14 KILL BC
+15 if SRD=""
QUIT
+16 ;calculate based on primary
+17 SET TYPE=$PIECE(^RMPR(660,SRD,0),U,4)
+18 SET TY=$SELECT(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
+19 SET SOURCE=$PIECE(^RMPR(660,SRD,0),U,14)
+20 SET COST=BTCOST
+21 ;stock issue display and calculate zero used cost if VA source
+22 ;I $P(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V") S BTCOST=0,COST=0
+23 ;I $P(^RMPR(660,SRD,0),U,13)["-3" S COST=0,SOURCE="VA",BTCOST=0
+24 SET QTY=$PIECE(^RMPR(660,SRD,0),U,7)
+25 SET ^TMP($JOB,CODE,SRD)=COST
+26 SET CATEGRY=$PIECE($GET(^RMPR(660,SRD,"AM")),U,3)
SET SPEC=$PIECE($GET(^("AM")),U,4)
SET GN=$PIECE(^("AMS"),U,1)
+27 ;new or repair code
+28 SET B1=SRD
+29 IF TY=2
DO REP
+30 IF TY'=2
DO NEW
+31 QUIT
SORT ;main data for worksheets
+1 SET TYPE=$PIECE(^RMPR(660,RD,0),U,4)
+2 SET TY=$SELECT(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
+3 SET SOURCE=$PIECE(^RMPR(660,RD,0),U,14)
+4 IF SOURCE=""
SET SOURCE="C"
+5 SET CATEGRY=$PIECE($GET(^RMPR(660,RD,"AM")),U,3)
SET SPEC=$PIECE($GET(^("AM")),U,4)
SET GN=$PIECE(^("AMS"),U,1)
+6 SET COST=$PIECE(^RMPR(660,RD,"LB"),U,9)
+7 ;stock issue source VA, used cost calculation is zero
+8 ;I $P(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V") S COST=0
+9 ;form
+10 SET FORM=$PIECE(^RMPR(660,RD,0),U,13)
+11 ;I (FORM=4)!(FORM=15) S COST=0,SOURCE="V"
+12 SET QTY=$PIECE(^RMPR(660,RD,0),U,7)
+13 SET B1=RD
+14 SET ^TMP($JOB,CODE,RD)=COST
+15 IF TY=2
DO REP
+16 IF TY'=2
DO NEW
+17 QUIT
REP ;calculate repair cost
+1 ;I $G(RD)'="" D
+2 ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
+3 ;.I SSN'="" S ^TMP($J,"A",SSN)=""
+4 ;.K SSN
+5 SET LINE=CODE
+6 IF LINE="R99 A"
SET SOURCE="C"
SET QTY=1
+7 IF $GET(^TMP($JOB,"R",STN,LINE))=""
SET ^TMP($JOB,"R",STN,LINE)=""
+8 IF SOURCE["V"
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,1)=$PIECE(^TMP($JOB,"R",STN,LINE),U,1)+QTY
+9 IF SOURCE["C"
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,2)=$PIECE(^TMP($JOB,"R",STN,LINE),U,2)+QTY
+10 ;
+11 SET $PIECE(^TMP($JOB,"R",STN,LINE),U,3)=$PIECE(^TMP($JOB,"R",STN,LINE),U,3)+COST
+12 IF CATEGRY=1
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,4)=$PIECE(^TMP($JOB,"R",STN,LINE),U,4)+1
+13 IF CATEGRY=4
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,5)=$PIECE(^TMP($JOB,"R",STN,LINE),U,5)+1
+14 IF CATEGRY=2
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,6)=$PIECE(^TMP($JOB,"R",STN,LINE),U,6)+1
+15 IF CATEGRY=3
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,7)=$PIECE(^TMP($JOB,"R",STN,LINE),U,7)+1
+16 IF SPEC=1
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,8)=$PIECE(^TMP($JOB,"R",STN,LINE),U,8)+1
+17 IF SPEC=2
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,9)=$PIECE(^TMP($JOB,"R",STN,LINE),U,9)+1
+18 IF SPEC=3
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,10)=$PIECE(^TMP($JOB,"R",STN,LINE),U,10)+1
+19 IF SPEC=4
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,11)=$PIECE(^TMP($JOB,"R",STN,LINE),U,11)+1
SET $PIECE(^(LINE),U,16)=$PIECE(^(LINE),U,16)+COST
+20 IF TYPE="I"
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,12)=$PIECE(^TMP($JOB,"R",STN,LINE),U,12)+1
+21 QUIT
+22 ;
NEW ;calculate new costs
+1 ;I $G(RD)'="" D
+2 ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
+3 ;.I SSN'="" S ^TMP($J,"A",SSN)=""
+4 ;.K SSN
+5 SET LINE=CODE
+6 IF $GET(^TMP($JOB,"N",STN,LINE))=""
SET ^TMP($JOB,"N",STN,LINE)=""
+7 IF SOURCE["V"
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,1)=$PIECE(^TMP($JOB,"N",STN,LINE),U,1)+QTY
+8 IF SOURCE["C"
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,2)=$PIECE(^TMP($JOB,"N",STN,LINE),U,2)+QTY
+9 SET $PIECE(^TMP($JOB,"N",STN,LINE),U,3)=$PIECE(^TMP($JOB,"N",STN,LINE),U,3)+COST
+10 IF CATEGRY=1
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,4)=$PIECE(^TMP($JOB,"N",STN,LINE),U,4)+1
+11 IF CATEGRY=4
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,5)=$PIECE(^TMP($JOB,"N",STN,LINE),U,5)+1
+12 IF CATEGRY=2
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,6)=$PIECE(^TMP($JOB,"N",STN,LINE),U,6)+1
+13 IF CATEGRY=3
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,7)=$PIECE(^TMP($JOB,"N",STN,LINE),U,7)+1
+14 IF SPEC=1
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,8)=$PIECE(^TMP($JOB,"N",STN,LINE),U,8)+1
+15 IF SPEC=2
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,9)=$PIECE(^TMP($JOB,"N",STN,LINE),U,9)+1
+16 IF SPEC=3
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,10)=$PIECE(^TMP($JOB,"N",STN,LINE),U,10)+1
+17 IF SPEC=4
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,11)=$PIECE(^TMP($JOB,"N",STN,LINE),U,11)+1
SET $PIECE(^(LINE),U,16)=$PIECE(^(LINE),U,16)+COST
+18 IF TYPE="I"
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,12)=$PIECE(^TMP($JOB,"N",STN,LINE),U,12)+1
+19 QUIT
