ECXAPRO ;ALB/JAP - PRO Extract Audit Report ;11/19/19 13:55
;;3.0;DSS EXTRACTS;**9,21,33,36,132,137,144,177**;Dec 22, 1997;Build 2
;
EN ;entry point for PRO extract audit report
N %X,%Y,DIV,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,CNT,ECXPORT ;144
S ECXERR=0
;ecxaud=0 for 'extract' audit
S ECXHEAD="PRO",ECXAUD=0
W !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
;determine primary division
S ECXPRIME=$$PDIV^ECXPUTL
I ECXPRIME=0 D ^ECXKILL Q
S DA=ECXPRIME,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1
S ECXPRIME=ECXPRIME_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))
;select 1 or more prosthetics divisions for report
D PRO^ECXDVSN2(DUZ,ECXPRIME,.ECXDIV,.ECXALL,.ECXERR)
I ECXERR D Q
.D ^ECXKILL W !!,?5,"Try again later... exiting.",!
;select extract
D AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
I ECXERR=1 D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
;if user's selected division doesn't match extract's division, then quit
I +ECXPRIME'=ECXARRAY("DIV") D Q
.S DIV=+ECXARRAY("DIV") S:$D(^DIC(4,DIV,0)) DIV=$P(^(0),U,1)
.W !!,?5,"Your primary division ("_$P(ECXPRIME,U,3)_") does not match the"
.W !,?5,"division ("_DIV_") associated with Extract #"_ECXARRAY("EXTRACT")_"."
.W !!,?5,"Try again... exiting.",!
.I $E(IOST)="C" D
..S SS=20-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR
..W @IOF
;select summary or detail
K DIR S DIR(0)="S^D:DETAIL;S:SUMMARY",DIR("A")="Type of Report",DIR("B")="SUMMARY"
D ^DIR K DIR
I $D(DIRUT)!($D(DTOUT)) D Q
.W !!,?5,"Try again later... exiting.",!
.D AUDIT^ECXKILL
S ECXREPT=Y
;continue with detail report
I ECXREPT="D" D I $G(ECXPORT) Q ;144 Stop processing if doing a detailed listing
.F D ASK2^ECXAPRO2 Q:$D(DIRUT)!($D(DTOUT))
;continue with summary report
I ECXREPT="S" D
.S ECXPGM="TASK^ECXAPRO",ECXDESC="PRO Extract Audit Report"
.S ECXSAVE("ECXHEAD")="",ECXSAVE("ECXDIV(")="",ECXSAVE("ECXARRAY(")="",ECXSAVE("ECXREPT")="",ECXSAVE("ECXPRIME")="",ECXSAVE("ECXALL")=""
.S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144
..K ^TMP($J) ;144
..S ^TMP($J,"ECXPORT",0)="STATION #^EXTRACT LOG #^TYPE^NPPD GROUP^NPPD LINE^VA^COM^TOTAL^COST^AVE COM" ;144
..S CNT=1 ;144
..D PROCESS ;144
..D DISP^ECXAPRO1 ;144
..D EXPDISP^ECXUTL1 ;144
..D ASK^ECXAPRO2 ;144
..D ^ECXKILL ;144
.W !
.;determine output device and queue if requested
.D DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE) I ECXSAVE("POP")=1 D Q
..W !!,?5,"Try again later... exiting.",!
..D AUDIT^ECXKILL
.I ECXSAVE("ZTSK")=0 D
..K ECXSAVE,ECXPGM,ECXDESC
..D PROCESS,DISP^ECXAPRO1
..;allow user to get details
..D ASK^ECXAPRO2
;clean-up and close
I $G(ECXPORT) Q ;144 Stop processing if exporting
I IO'=IO(0) D ^%ZISC
D HOME^%ZIS
D AUDIT^ECXKILL
Q
;
TASK ;entry point from taskmanager
D PROCESS
I ECXREPT="S" D DISP^ECXAPRO1
I ECXREPT="D" D DISP^ECXAPRO2
D AUDIT^ECXKILL
Q
;
PROCESS ;process the data in file #727.826
N J,CODE,COST,CPTNM,DATE,DESC,FLG,GN,IEN,KEY,LOC,LABLC,LABMC,NODE,PTNAM,PSASNM,QTY,QFLG,QQFLG,RD,SSN,STN,SRCE,TYPE,NPPDED ;144 NPPD ENT DATE CVW DAN removed CNT
N NODE2 ;177 Node2 will hold new cost data
I '$G(ECXPORT) K ^TMP($J) ;144 Killed already if exporting
S QQFLG=0 ;144 CNT removed as no longer needed
S ECXEXT=ECXARRAY("EXTRACT"),ECXDEF=ECXARRAY("DEF")
S X=ECXARRAY("START") D ^%DT S ECXSTART=Y S X=ECXARRAY("END") D ^%DT S ECXEND=Y
D NOW^%DTC S Y=$E(%,1,12) D DD^%DT S ECXRUN=Y
I ECXALL=0 S J=$O(ECXDIV(99),-1),ECXDIV=ECXDIV(J)
I ECXALL=1 S ECXDIV=ECXPRIME
S STN=$P(ECXDIV,U,2)
;initialize the prosthetics tmp global for cumulative data
D CODE^ECXAPRO1
;gather extract data and sort by grouper number, calc flag, and nppd code
S IEN="" F S IEN=$O(^ECX(727.826,"AC",ECXEXT,IEN)) Q:IEN="" D Q:QQFLG
.S ECXPRO=^ECX(727.826,IEN,0),NODE2=$G(^ECX(727.826,IEN,2)) ;177 Get node that contains new cost data
.;
.;- Remove trailing "^" from ECXPRO if there
.I $E(ECXPRO,$L(ECXPRO))="^" S ECXPRO=$E(ECXPRO,1,$L(ECXPRO)-1)
.S ECXPRO=ECXPRO_U_$P(^ECX(727.826,IEN,1),U,4)_U_$P(^ECX(727.826,IEN,2),U,4) ;NPPD ENTRY DATE 144 CVW
.S DATE=$P(ECXPRO,U,9)
.S $E(DATE,1,2)=$E(DATE,1,2)-17
.Q:$L(DATE)<7 Q:(DATE<ECXSTART) Q:(DATE>ECXEND)
.S DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
.S PTNAM=$P(ECXPRO,U,7),SSN=$E($P(ECXPRO,U,6),6,9)
.S LOC=$P(ECXPRO,U,10),KEY=$P(ECXPRO,U,11),QTY=$P(ECXPRO,U,12)
.S COST=$P(ECXPRO,U,25)+$P(NODE2,U,25),LABLC=$P(ECXPRO,U,26)+$P(NODE2,U,26),LABMC=$P(ECXPRO,U,27)+$P(NODE2,U,27) ;177 Costs are stored in ECXPRO if prior to FY20 and are in NODE2 for FY20 and beyond
.S GN=$P(ECXPRO,U,34),GN=$S(GN="":" ",1:GN),NPPDED=$P(ECXPRO,U,35) ;NPPD ENTRY DATE 144 CVW
.;don't double count lab items
.Q:LOC["LAB"
.;duplicate the logic in sort^rmprn6 that sets cost=0 if form=4
.I LOC["ORD" S COST=0
.S LOC=$S(LOC["ORD":$P(LOC,"ORD",1),LOC["HO2":$P(LOC,"HO2",1),1:$P(LOC,"NONL",1)) ;137
.;quit if feeder location isn't for division selected for report
.I ECXALL=1,LOC'[STN Q
.I ECXALL=0,LOC'=STN Q
.S TYPE=$E(KEY,6),SRCE=$E(KEY,7)
.S CPTNM=$P(ECXPRO,U,15),PSASNM=$P(ECXPRO,U,33)
.D GETCODE(PSASNM,.NODE)
.Q:NODE=""
.S CODE=$S(TYPE="X":$P(NODE,U,3),1:$P(NODE,U,4))
.S FLG=$P(NODE,U,2),DESC=$P(NODE,U,5)
.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_U_NPPDED ;144 CVW
;accumulate summary & detail data
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 D GROUP S FLG=2 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
....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)
....S ^TMP($J,CODE,RD)=^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)
....I TYPE="X" D REP(CODE)
....I TYPE="N" D NEW(CODE)
....I TYPE="R" D RENT(CODE)
Q
;
GETCODE(PSAS,NODE) ;find the appropriate nppd code using psas hcpcs
N DIC,X,Y,DESC,FLG,NU,REP
S NODE=""
S DIC="^RMPR(661.1,",DIC(0)="XZ",X=PSAS D ^DIC
I Y=-1 S NODE=U_"2"_U_"R99 Z"_U_"999 Z"_U_"NO HCPCS" Q
S DESC=$E($P(Y(0),U,2),1,20)
S FLG=$P(Y(0),U,8) S:FLG="" FLG=2
;make sure each code at least 4 characters; group codes are 3 characters in tmp($j,rmprcode)
S REP=$P(Y(0),U,6) S:$L(REP)=3 REP=REP_" " S:REP="" REP="R99 X"
S NU=$P(Y(0),U,7) S:$L(NU)=3 NU=NU_" " S:NU="" NU="999 X"
S NODE=U_FLG_U_REP_U_NU_U_DESC
Q
;
GROUP ;total grouper to main key
N BF,BL,BR,BCOST,BTCOST,COST,QTY,TYPE,SRCE
S BF=0,BTCOST=0
F S BF=$O(^TMP($J,"RMPRGN",STN,GN,BF)) Q:BF'>0 D
.S BL=0
.F S BL=$O(^TMP($J,"RMPRGN",STN,GN,BF,BL)) Q:BL="" D
..S BR=0
..F S BR=$O(^TMP($J,"RMPRGN",STN,GN,BF,BL,BR)) Q:BR'>0 D
...S BCOST=$P(^TMP($J,"RMPRGN",STN,GN,BF,BL,BR),U,4)
...S BTCOST=BTCOST+BCOST
S BL=$O(^TMP($J,"RMPRGN",STN,GN,1,"")),BR=$O(^TMP($J,"RMPRGN",STN,GN,1,BL,""))
;calculate based on primary
S TYPE=$P(^TMP($J,"RMPRGN",STN,GN,1,BL,BR),U,1),SRCE=$P(^(BR),U,2),QTY=$P(^(BR),U,3)
S COST=BTCOST
S ^TMP($J,BL,BR)=^TMP($J,"RMPRGN",STN,GN,1,BL,BR),$P(^TMP($J,BL,BR),U,4)=COST
I TYPE="X" D REP(BL)
I TYPE="N" D NEW(BL)
I TYPE="R" D RENT(BL)
Q
;
REP(C) ;calculate repair cost
N LINE
S LINE=C
I LINE="R90 A" S SRCE="C",QTY=1
I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
I SRCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
I SRCE["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
Q
;
NEW(C) ;calculate new costs
N LINE
S LINE=C
I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
I SRCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
I SRCE["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
Q
;
RENT(C) ;calculate rental costs
N LINE
S LINE=C
I $G(^TMP($J,"RT",STN,LINE))="" S ^TMP($J,"RT",STN,LINE)=""
I SRCE["V" S $P(^TMP($J,"RT",STN,LINE),U,1)=$P(^TMP($J,"RT",STN,LINE),U,1)+QTY
I SRCE["C" S $P(^TMP($J,"RT",STN,LINE),U,2)=$P(^TMP($J,"RT",STN,LINE),U,2)+QTY
S $P(^TMP($J,"RT",STN,LINE),U,3)=$P(^TMP($J,"RT",STN,LINE),U,3)+COST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXAPRO 8451 printed Oct 16, 2024@17:52:58 Page 2
ECXAPRO ;ALB/JAP - PRO Extract Audit Report ;11/19/19 13:55
+1 ;;3.0;DSS EXTRACTS;**9,21,33,36,132,137,144,177**;Dec 22, 1997;Build 2
+2 ;
EN ;entry point for PRO extract audit report
+1 ;144
NEW %X,%Y,DIV,X,Y,DIC,DA,DR,DIQ,DIR,DIRUT,DTOUT,DUOUT,CNT,ECXPORT
+2 SET ECXERR=0
+3 ;ecxaud=0 for 'extract' audit
+4 SET ECXHEAD="PRO"
SET ECXAUD=0
+5 WRITE !!,"Setup for ",ECXHEAD," Extract Audit Report --",!!
+6 ;determine primary division
+7 SET ECXPRIME=$$PDIV^ECXPUTL
+8 IF ECXPRIME=0
DO ^ECXKILL
QUIT
+9 SET DA=ECXPRIME
SET DIC="^DIC(4,"
SET DIQ(0)="I"
SET DIQ="ECXDIC"
SET DR=".01;99"
DO EN^DIQ1
+10 SET ECXPRIME=ECXPRIME_U_$GET(ECXDIC(4,DA,99,"I"))_U_$GET(ECXDIC(4,DA,.01,"I"))
+11 ;select 1 or more prosthetics divisions for report
+12 DO PRO^ECXDVSN2(DUZ,ECXPRIME,.ECXDIV,.ECXALL,.ECXERR)
+13 IF ECXERR
Begin DoDot:1
+14 DO ^ECXKILL
WRITE !!,?5,"Try again later... exiting.",!
End DoDot:1
QUIT
+15 ;select extract
+16 DO AUDIT^ECXUTLA(ECXHEAD,.ECXERR,.ECXARRAY,ECXAUD)
+17 IF ECXERR=1
Begin DoDot:1
+18 WRITE !!,?5,"Try again later... exiting.",!
+19 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+20 ;if user's selected division doesn't match extract's division, then quit
+21 IF +ECXPRIME'=ECXARRAY("DIV")
Begin DoDot:1
+22 SET DIV=+ECXARRAY("DIV")
if $DATA(^DIC(4,DIV,0))
SET DIV=$PIECE(^(0),U,1)
+23 WRITE !!,?5,"Your primary division ("_$PIECE(ECXPRIME,U,3)_") does not match the"
+24 WRITE !,?5,"division ("_DIV_") associated with Extract #"_ECXARRAY("EXTRACT")_"."
+25 WRITE !!,?5,"Try again... exiting.",!
+26 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+27 SET SS=20-$Y
FOR JJ=1:1:SS
WRITE !
+28 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
+29 WRITE @IOF
End DoDot:2
End DoDot:1
QUIT
+30 ;select summary or detail
+31 KILL DIR
SET DIR(0)="S^D:DETAIL;S:SUMMARY"
SET DIR("A")="Type of Report"
SET DIR("B")="SUMMARY"
+32 DO ^DIR
KILL DIR
+33 IF $DATA(DIRUT)!($DATA(DTOUT))
Begin DoDot:1
+34 WRITE !!,?5,"Try again later... exiting.",!
+35 DO AUDIT^ECXKILL
End DoDot:1
QUIT
+36 SET ECXREPT=Y
+37 ;continue with detail report
+38 ;144 Stop processing if doing a detailed listing
IF ECXREPT="D"
Begin DoDot:1
+39 FOR
DO ASK2^ECXAPRO2
if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
End DoDot:1
IF $GET(ECXPORT)
QUIT
+40 ;continue with summary report
+41 IF ECXREPT="S"
Begin DoDot:1
+42 SET ECXPGM="TASK^ECXAPRO"
SET ECXDESC="PRO Extract Audit Report"
+43 SET ECXSAVE("ECXHEAD")=""
SET ECXSAVE("ECXDIV(")=""
SET ECXSAVE("ECXARRAY(")=""
SET ECXSAVE("ECXREPT")=""
SET ECXSAVE("ECXPRIME")=""
SET ECXSAVE("ECXALL")=""
+44 ;144
SET ECXPORT=$$EXPORT^ECXUTL1
if ECXPORT=-1
QUIT
IF ECXPORT
Begin DoDot:2
+45 ;144
KILL ^TMP($JOB)
+46 ;144
SET ^TMP($JOB,"ECXPORT",0)="STATION #^EXTRACT LOG #^TYPE^NPPD GROUP^NPPD LINE^VA^COM^TOTAL^COST^AVE COM"
+47 ;144
SET CNT=1
+48 ;144
DO PROCESS
+49 ;144
DO DISP^ECXAPRO1
+50 ;144
DO EXPDISP^ECXUTL1
+51 ;144
DO ASK^ECXAPRO2
+52 ;144
DO ^ECXKILL
End DoDot:2
QUIT
+53 WRITE !
+54 ;determine output device and queue if requested
+55 DO DEVICE^ECXUTLA(ECXPGM,ECXDESC,.ECXSAVE)
IF ECXSAVE("POP")=1
Begin DoDot:2
+56 WRITE !!,?5,"Try again later... exiting.",!
+57 DO AUDIT^ECXKILL
End DoDot:2
QUIT
+58 IF ECXSAVE("ZTSK")=0
Begin DoDot:2
+59 KILL ECXSAVE,ECXPGM,ECXDESC
+60 DO PROCESS
DO DISP^ECXAPRO1
+61 ;allow user to get details
+62 DO ASK^ECXAPRO2
End DoDot:2
End DoDot:1
+63 ;clean-up and close
+64 ;144 Stop processing if exporting
IF $GET(ECXPORT)
QUIT
+65 IF IO'=IO(0)
DO ^%ZISC
+66 DO HOME^%ZIS
+67 DO AUDIT^ECXKILL
+68 QUIT
+69 ;
TASK ;entry point from taskmanager
+1 DO PROCESS
+2 IF ECXREPT="S"
DO DISP^ECXAPRO1
+3 IF ECXREPT="D"
DO DISP^ECXAPRO2
+4 DO AUDIT^ECXKILL
+5 QUIT
+6 ;
PROCESS ;process the data in file #727.826
+1 ;144 NPPD ENT DATE CVW DAN removed CNT
NEW J,CODE,COST,CPTNM,DATE,DESC,FLG,GN,IEN,KEY,LOC,LABLC,LABMC,NODE,PTNAM,PSASNM,QTY,QFLG,QQFLG,RD,SSN,STN,SRCE,TYPE,NPPDED
+2 ;177 Node2 will hold new cost data
NEW NODE2
+3 ;144 Killed already if exporting
IF '$GET(ECXPORT)
KILL ^TMP($JOB)
+4 ;144 CNT removed as no longer needed
SET QQFLG=0
+5 SET ECXEXT=ECXARRAY("EXTRACT")
SET ECXDEF=ECXARRAY("DEF")
+6 SET X=ECXARRAY("START")
DO ^%DT
SET ECXSTART=Y
SET X=ECXARRAY("END")
DO ^%DT
SET ECXEND=Y
+7 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
DO DD^%DT
SET ECXRUN=Y
+8 IF ECXALL=0
SET J=$ORDER(ECXDIV(99),-1)
SET ECXDIV=ECXDIV(J)
+9 IF ECXALL=1
SET ECXDIV=ECXPRIME
+10 SET STN=$PIECE(ECXDIV,U,2)
+11 ;initialize the prosthetics tmp global for cumulative data
+12 DO CODE^ECXAPRO1
+13 ;gather extract data and sort by grouper number, calc flag, and nppd code
+14 SET IEN=""
FOR
SET IEN=$ORDER(^ECX(727.826,"AC",ECXEXT,IEN))
if IEN=""
QUIT
Begin DoDot:1
+15 ;177 Get node that contains new cost data
SET ECXPRO=^ECX(727.826,IEN,0)
SET NODE2=$GET(^ECX(727.826,IEN,2))
+16 ;
+17 ;- Remove trailing "^" from ECXPRO if there
+18 IF $EXTRACT(ECXPRO,$LENGTH(ECXPRO))="^"
SET ECXPRO=$EXTRACT(ECXPRO,1,$LENGTH(ECXPRO)-1)
+19 ;NPPD ENTRY DATE 144 CVW
SET ECXPRO=ECXPRO_U_$PIECE(^ECX(727.826,IEN,1),U,4)_U_$PIECE(^ECX(727.826,IEN,2),U,4)
+20 SET DATE=$PIECE(ECXPRO,U,9)
+21 SET $EXTRACT(DATE,1,2)=$EXTRACT(DATE,1,2)-17
+22 if $LENGTH(DATE)<7
QUIT
if (DATE<ECXSTART)
QUIT
if (DATE>ECXEND)
QUIT
+23 SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)
+24 SET PTNAM=$PIECE(ECXPRO,U,7)
SET SSN=$EXTRACT($PIECE(ECXPRO,U,6),6,9)
+25 SET LOC=$PIECE(ECXPRO,U,10)
SET KEY=$PIECE(ECXPRO,U,11)
SET QTY=$PIECE(ECXPRO,U,12)
+26 ;177 Costs are stored in ECXPRO if prior to FY20 and are in NODE2 for FY20 and beyond
SET COST=$PIECE(ECXPRO,U,25)+$PIECE(NODE2,U,25)
SET LABLC=$PIECE(ECXPRO,U,26)+$PIECE(NODE2,U,26)
SET LABMC=$PIECE(ECXPRO,U,27)+$PIECE(NODE2,U,27)
+27 ;NPPD ENTRY DATE 144 CVW
SET GN=$PIECE(ECXPRO,U,34)
SET GN=$SELECT(GN="":" ",1:GN)
SET NPPDED=$PIECE(ECXPRO,U,35)
+28 ;don't double count lab items
+29 if LOC["LAB"
QUIT
+30 ;duplicate the logic in sort^rmprn6 that sets cost=0 if form=4
+31 IF LOC["ORD"
SET COST=0
+32 ;137
SET LOC=$SELECT(LOC["ORD":$PIECE(LOC,"ORD",1),LOC["HO2":$PIECE(LOC,"HO2",1),1:$PIECE(LOC,"NONL",1))
+33 ;quit if feeder location isn't for division selected for report
+34 IF ECXALL=1
IF LOC'[STN
QUIT
+35 IF ECXALL=0
IF LOC'=STN
QUIT
+36 SET TYPE=$EXTRACT(KEY,6)
SET SRCE=$EXTRACT(KEY,7)
+37 SET CPTNM=$PIECE(ECXPRO,U,15)
SET PSASNM=$PIECE(ECXPRO,U,33)
+38 DO GETCODE(PSASNM,.NODE)
+39 if NODE=""
QUIT
+40 SET CODE=$SELECT(TYPE="X":$PIECE(NODE,U,3),1:$PIECE(NODE,U,4))
+41 SET FLG=$PIECE(NODE,U,2)
SET DESC=$PIECE(NODE,U,5)
+42 ;144 CVW
SET ^TMP($JOB,"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_U_NPPDED
End DoDot:1
if QQFLG
QUIT
+43 ;accumulate summary & detail data
+44 SET GN=""
+45 FOR
SET GN=$ORDER(^TMP($JOB,"RMPRGN",STN,GN))
if GN=""
QUIT
Begin DoDot:1
+46 SET FLG=0
+47 FOR
SET FLG=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG))
if FLG'>0
QUIT
Begin DoDot:2
+48 IF FLG=1
DO GROUP
SET FLG=2
QUIT
+49 SET CODE=0
+50 FOR
SET CODE=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE))
if CODE=""
QUIT
Begin DoDot:3
+51 SET RD=0
+52 FOR
SET RD=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE,RD))
if RD'>0
QUIT
Begin DoDot:4
+53 SET TYPE=$PIECE(^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE,RD),U,1)
SET SRCE=$PIECE(^(RD),U,2)
SET QTY=$PIECE(^(RD),U,3)
SET COST=$PIECE(^(RD),U,4)
+54 SET ^TMP($JOB,CODE,RD)=^TMP($JOB,"RMPRGN",STN,GN,FLG,CODE,RD)
+55 IF TYPE="X"
DO REP(CODE)
+56 IF TYPE="N"
DO NEW(CODE)
+57 IF TYPE="R"
DO RENT(CODE)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+58 QUIT
+59 ;
GETCODE(PSAS,NODE) ;find the appropriate nppd code using psas hcpcs
+1 NEW DIC,X,Y,DESC,FLG,NU,REP
+2 SET NODE=""
+3 SET DIC="^RMPR(661.1,"
SET DIC(0)="XZ"
SET X=PSAS
DO ^DIC
+4 IF Y=-1
SET NODE=U_"2"_U_"R99 Z"_U_"999 Z"_U_"NO HCPCS"
QUIT
+5 SET DESC=$EXTRACT($PIECE(Y(0),U,2),1,20)
+6 SET FLG=$PIECE(Y(0),U,8)
if FLG=""
SET FLG=2
+7 ;make sure each code at least 4 characters; group codes are 3 characters in tmp($j,rmprcode)
+8 SET REP=$PIECE(Y(0),U,6)
if $LENGTH(REP)=3
SET REP=REP_" "
if REP=""
SET REP="R99 X"
+9 SET NU=$PIECE(Y(0),U,7)
if $LENGTH(NU)=3
SET NU=NU_" "
if NU=""
SET NU="999 X"
+10 SET NODE=U_FLG_U_REP_U_NU_U_DESC
+11 QUIT
+12 ;
GROUP ;total grouper to main key
+1 NEW BF,BL,BR,BCOST,BTCOST,COST,QTY,TYPE,SRCE
+2 SET BF=0
SET BTCOST=0
+3 FOR
SET BF=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,BF))
if BF'>0
QUIT
Begin DoDot:1
+4 SET BL=0
+5 FOR
SET BL=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,BF,BL))
if BL=""
QUIT
Begin DoDot:2
+6 SET BR=0
+7 FOR
SET BR=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,BF,BL,BR))
if BR'>0
QUIT
Begin DoDot:3
+8 SET BCOST=$PIECE(^TMP($JOB,"RMPRGN",STN,GN,BF,BL,BR),U,4)
+9 SET BTCOST=BTCOST+BCOST
End DoDot:3
End DoDot:2
End DoDot:1
+10 SET BL=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,1,""))
SET BR=$ORDER(^TMP($JOB,"RMPRGN",STN,GN,1,BL,""))
+11 ;calculate based on primary
+12 SET TYPE=$PIECE(^TMP($JOB,"RMPRGN",STN,GN,1,BL,BR),U,1)
SET SRCE=$PIECE(^(BR),U,2)
SET QTY=$PIECE(^(BR),U,3)
+13 SET COST=BTCOST
+14 SET ^TMP($JOB,BL,BR)=^TMP($JOB,"RMPRGN",STN,GN,1,BL,BR)
SET $PIECE(^TMP($JOB,BL,BR),U,4)=COST
+15 IF TYPE="X"
DO REP(BL)
+16 IF TYPE="N"
DO NEW(BL)
+17 IF TYPE="R"
DO RENT(BL)
+18 QUIT
+19 ;
REP(C) ;calculate repair cost
+1 NEW LINE
+2 SET LINE=C
+3 IF LINE="R90 A"
SET SRCE="C"
SET QTY=1
+4 IF $GET(^TMP($JOB,"R",STN,LINE))=""
SET ^TMP($JOB,"R",STN,LINE)=""
+5 IF SRCE["V"
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,1)=$PIECE(^TMP($JOB,"R",STN,LINE),U,1)+QTY
+6 IF SRCE["C"
SET $PIECE(^TMP($JOB,"R",STN,LINE),U,2)=$PIECE(^TMP($JOB,"R",STN,LINE),U,2)+QTY
+7 SET $PIECE(^TMP($JOB,"R",STN,LINE),U,3)=$PIECE(^TMP($JOB,"R",STN,LINE),U,3)+COST
+8 QUIT
+9 ;
NEW(C) ;calculate new costs
+1 NEW LINE
+2 SET LINE=C
+3 IF $GET(^TMP($JOB,"N",STN,LINE))=""
SET ^TMP($JOB,"N",STN,LINE)=""
+4 IF SRCE["V"
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,1)=$PIECE(^TMP($JOB,"N",STN,LINE),U,1)+QTY
+5 IF SRCE["C"
SET $PIECE(^TMP($JOB,"N",STN,LINE),U,2)=$PIECE(^TMP($JOB,"N",STN,LINE),U,2)+QTY
+6 SET $PIECE(^TMP($JOB,"N",STN,LINE),U,3)=$PIECE(^TMP($JOB,"N",STN,LINE),U,3)+COST
+7 QUIT
+8 ;
RENT(C) ;calculate rental costs
+1 NEW LINE
+2 SET LINE=C
+3 IF $GET(^TMP($JOB,"RT",STN,LINE))=""
SET ^TMP($JOB,"RT",STN,LINE)=""
+4 IF SRCE["V"
SET $PIECE(^TMP($JOB,"RT",STN,LINE),U,1)=$PIECE(^TMP($JOB,"RT",STN,LINE),U,1)+QTY
+5 IF SRCE["C"
SET $PIECE(^TMP($JOB,"RT",STN,LINE),U,2)=$PIECE(^TMP($JOB,"RT",STN,LINE),U,2)+QTY
+6 SET $PIECE(^TMP($JOB,"RT",STN,LINE),U,3)=$PIECE(^TMP($JOB,"RT",STN,LINE),U,3)+COST
+7 QUIT
