- 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 Jan 18, 2025@03:36:23 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