Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRN7

RMPRN7.m

Go to the documentation of this file.
  1. 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
  1. D DIV4^RMPRSIT G:$D(X) EXIT
  1. DATE S %DT="XEA",%DT("A")="Enter Date to Start NPPD Calculations From: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT
  1. S DATE(1)=+Y
  1. S %DT="XEA",%DT("A")="Enter End Date: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT S DATE(2)=+Y
  1. I DATE(1)>DATE(2) W !!,$C(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",! G DATE
  1. Q:$D(RMPRCDE)
  1. DET ;select detail or brief
  1. D DISP^RMPRN7S
  1. K DIR
  1. S DIR(0)="S^D:DETAIL;B:BRIEF"
  1. S DIR("A")="Type of Report",DIR("B")="DETAIL" D ^DIR
  1. Q:$D(DIRUT)!($D(DTOUT))
  1. S RMPRDET=Y
  1. DEV ;device
  1. S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRT
  1. I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
  1. I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")=""
  1. I S ZTRTN="PRT^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
  1. PRT ;print
  1. I '$D(IO("Q")) U IO
  1. D GNP,GNPC
  1. Q
  1. ENL ;entry point for one line
  1. D DIV4^RMPRSIT G:$D(X) EXIT
  1. S RMPRCDE=1
  1. D DATE
  1. G:'$D(DATE(1))!('$D(DATE(2))) EXIT
  1. ;single line always new and used (BOTH) sort
  1. S RMPRDET="D"
  1. D GNPCC,EXIT
  1. Q
  1. GNP ;gather nppd data
  1. S $P(LN,"-",IOM)=""
  1. S DATE=DATE(1)-1
  1. K ^TMP($J)
  1. F S DATE=$O(^RMPR(660,"B",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE(2)) D
  1. .S RMPRB=0
  1. .F S RMPRB=$O(^RMPR(660,"B",DATE,RMPRB)) Q:RMPRB'>0 D
  1. ..;define variables for record
  1. ..S REC=$G(^RMPR(660,RMPRB,0)) Q:REC=""
  1. ..Q:$P(REC,U,15)["*"
  1. ..Q:$P(REC,U,10)'=RMPR("STA")
  1. ..;check for used pip
  1. ..;if not LAB, quit
  1. ..I $P(REC,U,13)'=15&($P(REC,U,13)'=4) Q
  1. ..S TYPE=$P(REC,U,4)
  1. ..S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
  1. ..S MR=$P($G(^RMPR(660,RMPRB,1)),U,4)
  1. ..I $P(^RMPR(660,RMPRB,0),U,17)'=""&($P(^(0),U,26)="") S TY=2,LINE="R99 A",MR=2676
  1. ..;PICKUP AND DELIVERY
  1. ..I $P(^RMPR(660,RMPRB,0),U,26)'="" S TY=2,LINE="R80 D",MR=2951
  1. ..Q:MR=""
  1. ..; PATCH 70 Auto-fix
  1. ..K LINE
  1. ..I TY'=2 S LINE=$P(^RMPR(661.1,MR,0),U,7)
  1. ..I TY'=2&($G(LINE)="") D
  1. ...I TYPE=5 Q
  1. ...S ERR=""
  1. ...S LINE=$P(^RMPR(661.1,MR,0),U,6) S:MR=2676 LINE="R99 A"
  1. ...S TYPE="X"
  1. ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
  1. ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
  1. ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
  1. ...K DIE,DA,DR
  1. ...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
  1. ...S ^TMP($J,RMPRB)="NEW TO REPAIR"
  1. ...S B=RMPRB D DATA^RMPRN6XM
  1. ..I TY=2 S LINE=$P(^RMPR(661.1,MR,0),U,6) S:MR=2676 LINE="R99 A"
  1. ..I TY=2&($G(LINE)="") D
  1. ...I TYPE=5 Q
  1. ...S ERR=""
  1. ...S LINE=$P(^RMPR(661.1,MR,0),U,7)
  1. ...S TYPE="I"
  1. ...S DIE="^RMPR(660,",DA=RMPRB,DR="2///^S X=TYPE"
  1. ...L +^RMPR(660,RMPRB):1 I '$T S ERR=1
  1. ...I ERR="" D ^DIE L -^RMPR(660,RMPRB)
  1. ...K DIE,DA,DR
  1. ...I ERR=1 S ^TMP($J,RMPRB)="NO UPDATE!"
  1. ...S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
  1. ...S B=RMPRB D DATA^RMPRN6XM
  1. ..;
  1. ..;set to 999 group if null
  1. ..S FLAG=$P(^RMPR(661.1,MR,0),U,8)
  1. ..I FLAG="" S FLAG=2
  1. ..S CATEGRY=$P($G(^RMPR(660,RMPRB,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P($G(^("AMS")),U,1)
  1. ..Q:GN=""
  1. ..D SET
  1. D FMT^RMPRN6XM,MAIL^RMPRN6XM
  1. Q
  1. GNPC ;worksheet/detail
  1. S STN=RMPR("NAME")
  1. D CAL^RMPRN7
  1. S PAGE=0,FL=""
  1. D ^RMPRN7PT
  1. G:FL=1 EXIT
  1. D ^RMPRN7PR
  1. G:FL=1 EXIT
  1. I RMPRDET'="D" G EXIT
  1. D DESP^RMPRN73
  1. D DESPR^RMPRN73
  1. EXIT ;commom exit point
  1. K ^TMP($J) D KILL^XUSCLEAN
  1. D ^%ZISC
  1. Q
  1. GNPCC ;one line only
  1. S STN=RMPR("NAME")
  1. D CODE^RMPRN73
  1. D ^RMPRN7UT
  1. G:$D(DIRUT)!($D(DTOUT)) EXIT
  1. I $G(RMPRCDE)="" S RMPRCDE="",RMPRCDE=$O(BRA(Y,RMPRCDE))
  1. S Y=DATE(1) D DD^%DT S DATE(3)=Y,Y=DATE(2) D DD^%DT S DATE(4)=Y
  1. S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G PRTL
  1. I $D(IO("Q")) S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")=""
  1. I S ZTSAVE("DATE(")="",ZTSAVE("RMPRZ")="",ZTSAVE("RMPRDET")="",ZTSAVE("RMPRCDE")=""
  1. I S ZTRTN="PRTL^RMPRN7",ZTDESC="Prosthetic 2529-3 NPPD" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE G EXIT
  1. PRTL ;print one line entry from taskman
  1. I '$D(IO("Q")) U IO
  1. D GNP
  1. D CAL^RMPRN7
  1. S PAGE=0,FL=""
  1. S CODE=RMPRCDE
  1. D DESP^RMPRN7PL
  1. Q
  1. SET ;set temp global
  1. S STN=RMPR("NAME")
  1. S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE_"L",RMPRB)=""
  1. S RMSSN=$P(^RMPR(660,RMPRB,0),U,2) I RMSSN S RMSSN=$P(^DPT(RMSSN,0),U,9)
  1. I RMSSN'="" S ^TMP($J,"A",RMSSN)=""
  1. K RMSSN
  1. Q
  1. ;
  1. LOOP ;sort on hcpcs key and grouper is complete
  1. ;store in tmp($j,"N",station) or "R"
  1. S (TAM,T1,RMPRB,COUNT,CODE,RMPRAD,DATE,RMPRFG,RMPRT,RMPRI,RMPRNW,RMPRRPR)=0
  1. 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
  1. S DATE=DATE(1),RMPRB=0
  1. CAL ;loop through grouper key sort
  1. S STN=RMPR("NAME")
  1. D CODE^RMPRN73
  1. S GN=""
  1. F S GN=$O(^TMP($J,"RMPRGN",STN,GN)) Q:GN="" D
  1. .S FLG=0
  1. .F S FLG=$O(^TMP($J,"RMPRGN",STN,GN,FLG)) Q:FLG'>0 D I FLG=1&(RMPRDET'=2)!(RMPRDET'=5) Q
  1. ..;used items never get grouped
  1. ..I FLG=1&(RMPRDET'=2)&(RMPRDET'=5) D GROUP Q
  1. ..;I FLG=1 D GROUP Q
  1. ..S CODE=0
  1. ..F S CODE=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE)) Q:CODE="" D
  1. ...S RD=0
  1. ...F S RD=$O(^TMP($J,"RMPRGN",STN,GN,FLG,CODE,RD)) Q:RD'>0 D
  1. ....D SORT Q
  1. Q
  1. GROUP ;total grouper to main key
  1. M BC=^TMP($J,"RMPRGN",STN,GN)
  1. S BF=0,BTCOST=0,SRD=""
  1. ;bc array is entrie PO 2421
  1. F S BF=$O(BC(BF)) Q:BF'>0 D
  1. .;b1 is line,or code
  1. .S BL=0
  1. .F S BL=$O(BC(BF,BL)) Q:BL="" D
  1. ..S BR=0
  1. ..;BR is record number
  1. ..F S BR=$O(BC(BF,BL,BR)) Q:BR'>0 D
  1. ...S BCOST=$P(^RMPR(660,BR,"LB"),U,9)
  1. ...S BTCOST=BTCOST+BCOST
  1. ...I (BF=1)&(SRD="") S SRD=BR,CODE="",CODE=$O(BC(1,CODE))
  1. K BC
  1. Q:SRD=""
  1. ;calculate based on primary
  1. S TYPE=$P(^RMPR(660,SRD,0),U,4)
  1. S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
  1. S SOURCE=$P(^RMPR(660,SRD,0),U,14)
  1. S COST=BTCOST
  1. ;stock issue display and calculate zero used cost if VA source
  1. ;I $P(^RMPR(660,SRD,1),U,5)'=""&(SOURCE["V") S BTCOST=0,COST=0
  1. ;I $P(^RMPR(660,SRD,0),U,13)["-3" S COST=0,SOURCE="VA",BTCOST=0
  1. S QTY=$P(^RMPR(660,SRD,0),U,7)
  1. S ^TMP($J,CODE,SRD)=COST
  1. S CATEGRY=$P($G(^RMPR(660,SRD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
  1. ;new or repair code
  1. S B1=SRD
  1. I TY=2 D REP
  1. I TY'=2 D NEW
  1. Q
  1. SORT ;main data for worksheets
  1. S TYPE=$P(^RMPR(660,RD,0),U,4)
  1. S TY=$S(TYPE="X":2,TYPE=5:2,TYPE="I":1,1:3)
  1. S SOURCE=$P(^RMPR(660,RD,0),U,14)
  1. I SOURCE="" S SOURCE="C"
  1. S CATEGRY=$P($G(^RMPR(660,RD,"AM")),U,3),SPEC=$P($G(^("AM")),U,4),GN=$P(^("AMS"),U,1)
  1. S COST=$P(^RMPR(660,RD,"LB"),U,9)
  1. ;stock issue source VA, used cost calculation is zero
  1. ;I $P(^RMPR(660,RD,1),U,5)'=""&(SOURCE["V") S COST=0
  1. ;form
  1. S FORM=$P(^RMPR(660,RD,0),U,13)
  1. ;I (FORM=4)!(FORM=15) S COST=0,SOURCE="V"
  1. S QTY=$P(^RMPR(660,RD,0),U,7)
  1. S B1=RD
  1. S ^TMP($J,CODE,RD)=COST
  1. I TY=2 D REP
  1. I TY'=2 D NEW
  1. Q
  1. REP ;calculate repair cost
  1. ;I $G(RD)'="" D
  1. ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
  1. ;.I SSN'="" S ^TMP($J,"A",SSN)=""
  1. ;.K SSN
  1. S LINE=CODE
  1. I LINE="R99 A" S SOURCE="C",QTY=1
  1. I $G(^TMP($J,"R",STN,LINE))="" S ^TMP($J,"R",STN,LINE)=""
  1. I SOURCE["V" S $P(^TMP($J,"R",STN,LINE),U,1)=$P(^TMP($J,"R",STN,LINE),U,1)+QTY
  1. I SOURCE["C" S $P(^TMP($J,"R",STN,LINE),U,2)=$P(^TMP($J,"R",STN,LINE),U,2)+QTY
  1. ;
  1. S $P(^TMP($J,"R",STN,LINE),U,3)=$P(^TMP($J,"R",STN,LINE),U,3)+COST
  1. I CATEGRY=1 S $P(^TMP($J,"R",STN,LINE),U,4)=$P(^TMP($J,"R",STN,LINE),U,4)+1
  1. I CATEGRY=4 S $P(^TMP($J,"R",STN,LINE),U,5)=$P(^TMP($J,"R",STN,LINE),U,5)+1
  1. I CATEGRY=2 S $P(^TMP($J,"R",STN,LINE),U,6)=$P(^TMP($J,"R",STN,LINE),U,6)+1
  1. I CATEGRY=3 S $P(^TMP($J,"R",STN,LINE),U,7)=$P(^TMP($J,"R",STN,LINE),U,7)+1
  1. I SPEC=1 S $P(^TMP($J,"R",STN,LINE),U,8)=$P(^TMP($J,"R",STN,LINE),U,8)+1
  1. I SPEC=2 S $P(^TMP($J,"R",STN,LINE),U,9)=$P(^TMP($J,"R",STN,LINE),U,9)+1
  1. I SPEC=3 S $P(^TMP($J,"R",STN,LINE),U,10)=$P(^TMP($J,"R",STN,LINE),U,10)+1
  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
  1. I TYPE="I" S $P(^TMP($J,"R",STN,LINE),U,12)=$P(^TMP($J,"R",STN,LINE),U,12)+1
  1. Q
  1. ;
  1. NEW ;calculate new costs
  1. ;I $G(RD)'="" D
  1. ;.S SSN=$P(^RMPR(660,RD,0),U,2) I SSN S SSN=$P(^DPT(SSN,0),U,9)
  1. ;.I SSN'="" S ^TMP($J,"A",SSN)=""
  1. ;.K SSN
  1. S LINE=CODE
  1. I $G(^TMP($J,"N",STN,LINE))="" S ^TMP($J,"N",STN,LINE)=""
  1. I SOURCE["V" S $P(^TMP($J,"N",STN,LINE),U,1)=$P(^TMP($J,"N",STN,LINE),U,1)+QTY
  1. I SOURCE["C" S $P(^TMP($J,"N",STN,LINE),U,2)=$P(^TMP($J,"N",STN,LINE),U,2)+QTY
  1. S $P(^TMP($J,"N",STN,LINE),U,3)=$P(^TMP($J,"N",STN,LINE),U,3)+COST
  1. I CATEGRY=1 S $P(^TMP($J,"N",STN,LINE),U,4)=$P(^TMP($J,"N",STN,LINE),U,4)+1
  1. I CATEGRY=4 S $P(^TMP($J,"N",STN,LINE),U,5)=$P(^TMP($J,"N",STN,LINE),U,5)+1
  1. I CATEGRY=2 S $P(^TMP($J,"N",STN,LINE),U,6)=$P(^TMP($J,"N",STN,LINE),U,6)+1
  1. I CATEGRY=3 S $P(^TMP($J,"N",STN,LINE),U,7)=$P(^TMP($J,"N",STN,LINE),U,7)+1
  1. I SPEC=1 S $P(^TMP($J,"N",STN,LINE),U,8)=$P(^TMP($J,"N",STN,LINE),U,8)+1
  1. I SPEC=2 S $P(^TMP($J,"N",STN,LINE),U,9)=$P(^TMP($J,"N",STN,LINE),U,9)+1
  1. I SPEC=3 S $P(^TMP($J,"N",STN,LINE),U,10)=$P(^TMP($J,"N",STN,LINE),U,10)+1
  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
  1. I TYPE="I" S $P(^TMP($J,"N",STN,LINE),U,12)=$P(^TMP($J,"N",STN,LINE),U,12)+1
  1. Q