257 lines
9.4 KiB
Mathematica
257 lines
9.4 KiB
Mathematica
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**;Feb 09, 1996
|
|
;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
|
|
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 used pip sort, not pip, not va, quit
|
|
..I $G(RMPRDET)=2&($P($G(^RMPR(660,RMPRB,1)),U,5)'="")&($P(REC,U,14)'="V") Q
|
|
..I $G(RMPRDET)=5&($P($G(^RMPR(660,RMPRB,1)),U,5)'="")&($P(REC,U,14)'="V") 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="R90 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 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)
|
|
..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="R90 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
|