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

RMPRN6.m

Go to the documentation of this file. 
  1. 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
  1.  ;RVD 3/17/03 patch #77 - fix undefined and closing device.
  1.  ;SPS 5/24/05 Patch #90 - check for type of 5 Rental.
  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^RMPRN6S
  1.  K DIR
  1.  ;S DIR(0)="S^D:DETAIL;B:BRIEF"
  1.  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"
  1.  S DIR("A")="Type of Report",DIR("B")="DETAIL & NEW SUMMARY" 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^RMPRN6",ZTDESC="Prosthetic 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=6
  1.  D GNPCC,EXIT
  1.  Q
  1. GNP ;gather nppd data
  1.  N SORTERR
  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.  ..;RMPR*3.0*165 corrected logic for new/used reporting criteria
  1.  ..;check for USED ONLY pip
  1.  ..;if USED pip sort, not pip or not 'va', quit
  1.  ..S SORTERR=0
  1.  ..I $G(RMPRDET)=2!($G(RMPRDET)=5) D  Q:SORTERR
  1.  ... I $P($G(^RMPR(660,RMPRB,1)),U,5)="" S SORTERR=1
  1.  ... I $P(REC,U,14)'="V" S SORTERR=1
  1.  ..;check for NEW ONLY pip
  1.  ..;if NEW pip sort, pip, va, quit
  1.  ..I $G(RMPRDET)=1!($G(RMPRDET)=4) D  Q:SORTERR
  1.  ... I $P($G(^RMPR(660,RMPRB,1)),U,5)="" Q
  1.  ... I $P(REC,U,14)="V" S SORTERR=1
  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,"RMPRA",RMPRB)="NO UPDATE!"
  1.  ...I ERR="" S ^TMP($J,"RMPRA",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,"RMPRA",RMPRB)="NO UPDATE!"
  1.  ...I ERR="" S ^TMP($J,"RMPRA",RMPRB)="REPAIR TO NEW"
  1.  ...S B=RMPRB D DATA^RMPRN6XM
  1.  ..;
  1.  ..I LINE="" W !,"Line is null, something wrong with file 661.1  :",MR
  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^RMPRN6
  1.  S PAGE=0,FL=""
  1.  D ^RMPRN6PT
  1.  G:FL=1 EXIT
  1.  D ^RMPRN6PR
  1.  G:FL=1 EXIT
  1.  I RMPRDET<4 G EXIT
  1.  D DESP^RMPRN63
  1.  D DESPR^RMPRN63
  1. EXIT ;commom exit point
  1.  D ^%ZISC
  1.  N RMPR,RMPRSITE
  1.  K ^TMP($J) D KILL^XUSCLEAN
  1.  Q
  1. GNPCC ;one line only
  1.  S STN=RMPR("NAME")
  1.  D CODE^RMPRN63
  1.  D ^RMPRN6UT
  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^RMPRN6",ZTDESC="Prosthetic 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^RMPRN6
  1.  S PAGE=0,FL=""
  1.  S CODE=RMPRCDE
  1.  D DESP^RMPRN6PL
  1.  Q
  1. SET ;set temp global
  1.  S STN=RMPR("NAME")
  1.  S ^TMP($J,"RMPRGN",STN,GN,FLAG,LINE,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^RMPRN63
  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.  ....I RMPRDET=1!(RMPRDET=4) D SORT Q
  1.  ....I RMPRDET=2!(RMPRDET=5) D SORTUSED^RMPRN6S Q
  1.  ....I RMPRDET=3!(RMPRDET=6) D SORTBOTH^RMPRN6S Q
  1.  ....;D SORT
  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,0),U,16)
  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,0),U,16)
  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