RMPRN6 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;3/17/03 11:38
;;3.0;PROSTHETICS;**31,32,34,36,39,48,51,70,77,90,144,165**;Feb 09, 1996;Build 4
;RVD 3/17/03 patch #77 - fix undefined and closing device.
;SPS 5/24/05 Patch #90 - check for type of 5 Rental.
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^RMPRN6S
K DIR
;S DIR(0)="S^D:DETAIL;B:BRIEF"
S DIR(0)="S^1:BRIEF NEW SUMMARY;2:BRIEF USED SUMMARY;3:BRIEF BOTH SUMMARY;4:DETAIL & NEW SUMMARY;5:DETAIL & USED SUMMARY;6:DETAIL & BOTH SUMMARY"
S DIR("A")="Type of Report",DIR("B")="DETAIL & NEW SUMMARY" 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^RMPRN6",ZTDESC="Prosthetic 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=6
D GNPCC,EXIT
Q
GNP ;gather nppd data
N SORTERR
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")
..;RMPR*3.0*165 corrected logic for new/used reporting criteria
..;check for USED ONLY pip
..;if USED pip sort, not pip or not 'va', quit
..S SORTERR=0
..I $G(RMPRDET)=2!($G(RMPRDET)=5) D Q:SORTERR
... I $P($G(^RMPR(660,RMPRB,1)),U,5)="" S SORTERR=1
... I $P(REC,U,14)'="V" S SORTERR=1
..;check for NEW ONLY pip
..;if NEW pip sort, pip, va, quit
..I $G(RMPRDET)=1!($G(RMPRDET)=4) D Q:SORTERR
... I $P($G(^RMPR(660,RMPRB,1)),U,5)="" Q
... I $P(REC,U,14)="V" S SORTERR=1
..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,"RMPRA",RMPRB)="NO UPDATE!"
...I ERR="" S ^TMP($J,"RMPRA",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,"RMPRA",RMPRB)="NO UPDATE!"
...I ERR="" S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
...S B=RMPRB D DATA^RMPRN6XM
..;
..I LINE="" W !,"Line is null, something wrong with file 661.1 :",MR
..;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^RMPRN6
S PAGE=0,FL=""
D ^RMPRN6PT
G:FL=1 EXIT
D ^RMPRN6PR
G:FL=1 EXIT
I RMPRDET<4 G EXIT
D DESP^RMPRN63
D DESPR^RMPRN63
EXIT ;commom exit point
D ^%ZISC
N RMPR,RMPRSITE
K ^TMP($J) D KILL^XUSCLEAN
Q
GNPCC ;one line only
S STN=RMPR("NAME")
D CODE^RMPRN63
D ^RMPRN6UT
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^RMPRN6",ZTDESC="Prosthetic 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^RMPRN6
S PAGE=0,FL=""
S CODE=RMPRCDE
D DESP^RMPRN6PL
Q
SET ;set temp global
S STN=RMPR("NAME")
S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE,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^RMPRN63
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
....I RMPRDET=1!(RMPRDET=4) D SORT Q
....I RMPRDET=2!(RMPRDET=5) D SORTUSED^RMPRN6S Q
....I RMPRDET=3!(RMPRDET=6) D SORTBOTH^RMPRN6S Q
....;D SORT
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,0),U,16)
...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,0),U,16)
;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[HRMPRN6 10224 printed Nov 22, 2024@17:45:04 Page 2
RMPRN6 ;Hines OIFO/HNC-PRINT NPPD LOCAL DATA ;3/17/03 11:38
+1 ;;3.0;PROSTHETICS;**31,32,34,36,39,48,51,70,77,90,144,165**;Feb 09, 1996;Build 4
+2 ;RVD 3/17/03 patch #77 - fix undefined and closing device.
+3 ;SPS 5/24/05 Patch #90 - check for type of 5 Rental.
+4 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^RMPRN6S
+2 KILL DIR
+3 ;S DIR(0)="S^D:DETAIL;B:BRIEF"
+4 SET DIR(0)="S^1:BRIEF NEW SUMMARY;2:BRIEF USED SUMMARY;3:BRIEF BOTH SUMMARY;4:DETAIL & NEW SUMMARY;5:DETAIL & USED SUMMARY;6:DETAIL & BOTH SUMMARY"
+5 SET DIR("A")="Type of Report"
SET DIR("B")="DETAIL & NEW SUMMARY"
DO ^DIR
+6 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+7 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^RMPRN6"
SET ZTDESC="Prosthetic 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=6
+7 DO GNPCC
DO EXIT
+8 QUIT
GNP ;gather nppd data
+1 NEW SORTERR
+2 SET $PIECE(LN,"-",IOM)=""
+3 SET DATE=DATE(1)-1
+4 KILL ^TMP($JOB)
+5 FOR
SET DATE=$ORDER(^RMPR(660,"B",DATE))
if (DATE="")!($PIECE(DATE,".",1)>DATE(2))
QUIT
Begin DoDot:1
+6 SET RMPRB=0
+7 FOR
SET RMPRB=$ORDER(^RMPR(660,"B",DATE,RMPRB))
if RMPRB'>0
QUIT
Begin DoDot:2
+8 ;define variables for record
+9 SET REC=$GET(^RMPR(660,RMPRB,0))
if REC=""
QUIT
+10 if $PIECE(REC,U,15)["*"
QUIT
+11 if $PIECE(REC,U,10)'=RMPR("STA")
QUIT
+12 ;RMPR*3.0*165 corrected logic for new/used reporting criteria
+13 ;check for USED ONLY pip
+14 ;if USED pip sort, not pip or not 'va', quit
+15 SET SORTERR=0
+16 IF $GET(RMPRDET)=2!($GET(RMPRDET)=5)
Begin DoDot:3
+17 IF $PIECE($GET(^RMPR(660,RMPRB,1)),U,5)=""
SET SORTERR=1
+18 IF $PIECE(REC,U,14)'="V"
SET SORTERR=1
End DoDot:3
if SORTERR
QUIT
+19 ;check for NEW ONLY pip
+20 ;if NEW pip sort, pip, va, quit
+21 IF $GET(RMPRDET)=1!($GET(RMPRDET)=4)
Begin DoDot:3
+22 IF $PIECE($GET(^RMPR(660,RMPRB,1)),U,5)=""
QUIT
+23 IF $PIECE(REC,U,14)="V"
SET SORTERR=1
End DoDot:3
if SORTERR
QUIT
+24 SET TYPE=$PIECE(REC,U,4)
+25 SET TY=$SELECT(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
+26 SET MR=$PIECE($GET(^RMPR(660,RMPRB,1)),U,4)
+27 IF $PIECE(^RMPR(660,RMPRB,0),U,17)'=""&($PIECE(^(0),U,26)="")
SET TY=2
SET LINE="R99 A"
SET MR=2676
+28 ;PICKUP AND DELIVERY
+29 IF $PIECE(^RMPR(660,RMPRB,0),U,26)'=""
SET TY=2
SET LINE="R80 D"
SET MR=2951
+30 if MR=""
QUIT
+31 ; PATCH 70 Auto-fix
+32 KILL LINE
+33 IF TY'=2
SET LINE=$PIECE(^RMPR(661.1,MR,0),U,7)
+34 IF TY'=2&($GET(LINE)="")
Begin DoDot:3
+35 ; I TYPE=5 Q
+36 SET ERR=""
+37 SET LINE=$PIECE(^RMPR(661.1,MR,0),U,6)
if MR=2676
SET LINE="R99 A"
+38 SET TYPE="X"
+39 SET DIE="^RMPR(660,"
SET DA=RMPRB
SET DR="2///^S X=TYPE"
+40 LOCK +^RMPR(660,RMPRB):1
IF '$TEST
SET ERR=1
+41 IF ERR=""
DO ^DIE
LOCK -^RMPR(660,RMPRB)
+42 KILL DIE,DA,DR
+43 IF ERR=1
SET ^TMP($JOB,"RMPRA",RMPRB)="NO UPDATE!"
+44 IF ERR=""
SET ^TMP($JOB,"RMPRA",RMPRB)="NEW TO REPAIR"
+45 SET B=RMPRB
DO DATA^RMPRN6XM
End DoDot:3
+46 IF TY=2
SET LINE=$PIECE(^RMPR(661.1,MR,0),U,6)
if MR=2676
SET LINE="R99 A"
+47 IF TY=2&($GET(LINE)="")
Begin DoDot:3
+48 ; I TYPE=5 Q
+49 SET ERR=""
+50 SET LINE=$PIECE(^RMPR(661.1,MR,0),U,7)
+51 SET TYPE="I"
+52 SET DIE="^RMPR(660,"
SET DA=RMPRB
SET DR="2///^S X=TYPE"
+53 LOCK +^RMPR(660,RMPRB):1
IF '$TEST
SET ERR=1
+54 IF ERR=""
DO ^DIE
LOCK -^RMPR(660,RMPRB)
+55 KILL DIE,DA,DR
+56 IF ERR=1
SET ^TMP($JOB,"RMPRA",RMPRB)="NO UPDATE!"
+57 IF ERR=""
SET ^TMP($JOB,"RMPRA",RMPRB)="REPAIR TO NEW"
+58 SET B=RMPRB
DO DATA^RMPRN6XM
End DoDot:3
+59 ;
+60 IF LINE=""
WRITE !,"Line is null, something wrong with file 661.1 :",MR
+61 ;set to 999 group if null
+62 SET FLAG=$PIECE(^RMPR(661.1,MR,0),U,8)
+63 IF FLAG=""
SET FLAG=2
+64 SET CATEGRY=$PIECE($GET(^RMPR(660,RMPRB,"AM")),U,3)
SET SPEC=$PIECE($GET(^("AM")),U,4)
SET GN=$PIECE($GET(^("AMS")),U,1)
+65 if GN=""
QUIT
+66 DO SET
End DoDot:2
End DoDot:1
+67 DO FMT^RMPRN6XM
DO MAIL^RMPRN6XM
+68 QUIT
GNPC ;worksheet/detail
+1 SET STN=RMPR("NAME")
+2 DO CAL^RMPRN6
+3 SET PAGE=0
SET FL=""
+4 DO ^RMPRN6PT
+5 if FL=1
GOTO EXIT
+6 DO ^RMPRN6PR
+7 if FL=1
GOTO EXIT
+8 IF RMPRDET<4
GOTO EXIT
+9 DO DESP^RMPRN63
+10 DO DESPR^RMPRN63
EXIT ;commom exit point
+1 DO ^%ZISC
+2 NEW RMPR,RMPRSITE
+3 KILL ^TMP($JOB)
DO KILL^XUSCLEAN
+4 QUIT
GNPCC ;one line only
+1 SET STN=RMPR("NAME")
+2 DO CODE^RMPRN63
+3 DO ^RMPRN6UT
+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^RMPRN6"
SET ZTDESC="Prosthetic 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^RMPRN6
+4 SET PAGE=0
SET FL=""
+5 SET CODE=RMPRCDE
+6 DO DESP^RMPRN6PL
+7 QUIT
SET ;set temp global
+1 SET STN=RMPR("NAME")
+2 SET ^TMP($JOB,"RMPRGN",STN,GN,FLAG,LINE,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^RMPRN63
+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 IF RMPRDET=1!(RMPRDET=4)
DO SORT
QUIT
+15 IF RMPRDET=2!(RMPRDET=5)
DO SORTUSED^RMPRN6S
QUIT
+16 IF RMPRDET=3!(RMPRDET=6)
DO SORTBOTH^RMPRN6S
QUIT
+17 ;D SORT
End DoDot:4
End DoDot:3
End DoDot:2
IF FLG=1&(RMPRDET'=2)!(RMPRDET'=5)
QUIT
End DoDot:1
+18 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,0),U,16)
+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 IF $PIECE(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V")
SET BTCOST=0
SET COST=0
+23 IF $PIECE(^RMPR(660,SRD,0),U,13)["-3"
SET COST=0
SET SOURCE="VA"
SET 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,0),U,16)
+7 ;stock issue source VA, used cost calculation is zero
+8 IF $PIECE(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V")
SET COST=0
+9 ;form
+10 SET FORM=$PIECE(^RMPR(660,RD,0),U,13)
+11 IF (FORM=4)!(FORM=15)
SET COST=0
SET 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
