RMPR7 ;PHX/JLT-PRINT LAB/RESTORATIONS WORKSHEET ;8/29/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
D DIV4^RMPRSIT G:$D(X) EXIT
DATE S %DT="XEA",%DT("A")="Enter Date to Start AMIS 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
K RMPRE S DIC="^RMPR(663,",DIC(0)="AEQMZ",DIC("A")="Select AMIS Line Item or <RETURN> for all: ",DIC("S")="S ZVAR=$P(^(0),U,4) I ZVAR=""O""!(ZVAR=""OR"")!(ZVAR=""R"")!(ZVAR=""RR"")"
D ^DIC G:(X["^")!$D(DTOUT) EXIT K DIC I Y>0 S RMPRE=+Y
DEV S %ZIS="MQ" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G FIND
I $D(IO("Q")) D G EXIT
.S ZTIO=ION,ZTSAVE("RMPRSITE")="",ZTSAVE("RMPR(")="",ZTSAVE("DATE(")="",ZTRTN="FIND^RMPR7" S ZTDESC="Prosthetic LAB or RESTORATIONS AMIS" D ^%ZTLOAD K ZTDESC,ZTIO,ZTRTN,ZTSAVE
FIND ;Entry Point to calculate Amis
U IO K ^TMP($J)
S RMPRDT=DATE(1)-1 I $D(RMPRGEC) D BLD^RMPR31U
F S RMPRDT=$O(^RMPR(660,"B",RMPRDT)) Q:RMPRDT>DATE(2)!(RMPRDT'>0) F RMPRBL=0:0 S RMPRBL=$O(^RMPR(660,"B",RMPRDT,RMPRBL)) Q:RMPRBL'>0 S BLG=$G(^RMPR(660,RMPRBL,"LB")) I BLG'="" D
.S INF=$G(^RMPR(660,RMPRBL,0)),RMPRAM=$G(^("AM"))
.Q:RMPR("STA")'=$P(BLG,U,4) Q:$P(BLG,U,14) Q:$P(BLG,U,11)&($P(BLG,U,11)'>DATE(2))
.I $D(RMPRGEC) S PDZ=$G(^RMPR(661,+$P(INF,U,6),0)) I PDZ S CODE=$$CODE^RMPR31U(PDZ,$P(INF,U,4),$P(BLG,U,3)) I +CODE D:$P(CODE,U)'=138&($P(CODE,U)'=134) BLG
.I '$D(RMPRGEC) S RMPRWO=$P($G(^RMPR(664.2,+$P(BLG,U,5),0)),U) I RMPRWO'="" S PDZ=$G(^RMPR(661,+$P(INF,U,6),0)) I PDZ S CODE=$$CODE^RMPR31U(PDZ,$P(INF,U,4),$P(BLG,U,3)) I +CODE D BLG
S RMPRDT=DATE(1)-1
F S RMPRDT=$O(^RMPR(660,"CD",RMPRDT)) Q:RMPRDT'>0!(RMPRDT>DATE(2)) F RMPRBL=0:0 S RMPRBL=$O(^RMPR(660,"CD",RMPRDT,RMPRBL)) Q:RMPRBL'>0 I $D(^RMPR(660,RMPRBL,"LB")) S BLG=^("LB"),INF=$G(^RMPR(660,RMPRBL,0)),RMPRAM=$G(^("AM")) D
.Q:RMPR("STA")'=$P(BLG,U,4) Q:$P(BLG,U,14)
.I $D(RMPRGEC) S PDZ=$G(^RMPR(661,+$P(INF,U,6),0)) I PDZ S CODE=$$CODE^RMPR31U(PDZ,$P(INF,U,4),$P(BLG,U,3)) I +CODE D COM
.I '$D(RMPRGEC) S RMPRWO=$P($G(^RMPR(664.2,+$P(BLG,U,5),0)),U) I RMPRWO'="" S PDZ=$G(^RMPR(661,+$P(INF,U,6),0)) I PDZ S CODE=$$CODE^RMPR31U(PDZ,$P(INF,U,4),$P(BLG,U,3)) I +CODE D COM
I $D(^TMP($J)),'$D(RMPRGEC) D ^RMPR71
EXIT Q:$D(RMPRGEC) K ^TMP($J) D ^%ZISC N RMPR,RMPRSITE D KILL^XUSCLEAN Q
BLG S:'$D(RMPRGEC) RDATA=$G(^TMP($J,CODE,RMPRDT,RMPRWO)) S:$D(RMPRGEC) RDATA=$G(^TMP($J,CODE))
S $P(RDATA,U)=$P(BLG,U)
S $P(RDATA,U,9)=$P(RDATA,U,9)+$P(INF,U,7),$P(RDATA,U,10)=$P(RDATA,U,10)+$P($P(BLG,U,6),"."),$P(RDATA,U,11)=$P(RDATA,U,11)+$P($P(BLG,U,6),".",2),$P(RDATA,U,12)=$P(RDATA,U,12)+$P(BLG,U,9)
I '$D(RMPRGEC) S ^TMP($J,CODE,RMPRDT,RMPRWO)=RDATA
I $D(RMPRGEC) S ^TMP($J,CODE)=RDATA
K RDATA
Q
COM I '$D(RMPRGEC) S RDATA=$G(^TMP($J,CODE,RMPRDT,RMPRWO))
I $D(RMPRGEC)&($P(CODE,U)'=138)&($P(CODE,U)'=134) S RDATA=$G(^TMP($J,CODE))
I $D(RMPRGEC)&($P(CODE,U)=138)!($P(CODE,U)=134) S RDATA=$G(^TMP($J,$P(CODE,U),$$STAN^RMPR31U(+BLG)))
S $P(RDATA,U)=$P(BLG,U)
S $P(RDATA,U,2)=$P(RDATA,U,2)+$P(INF,U,7)
I '$D(RMPRGEC) S:$P(RMPRAM,U,3)<3 $P(RDATA,U,3)=1 S:$P(RMPRAM,U,3)>2 $P(RDATA,U,4)=1
I $D(RMPRGEC) S:$P(RMPRAM,U,3)<3 $P(RDATA,U,3)=$P(RDATA,U,3)+1 S:$P(RMPRAM,U,3)>2 $P(RDATA,U,4)=$P(RDATA,U,4)+1
S $P(RDATA,U,5)=$P(RDATA,U,5)+$P(BLG,U,8),$P(RDATA,U,6)=$P(RDATA,U,6)+$P($P(BLG,U,6),"."),$P(RDATA,U,7)=$P(RDATA,U,7)+$P($P(BLG,U,6),".",2),$P(RDATA,U,8)=$P(RDATA,U,8)+$P(BLG,U,7)
I '$D(RMPRGEC) S ^TMP($J,CODE,RMPRDT,RMPRWO)=RDATA
I $D(RMPRGEC)&($P(CODE,U)'=138)&($P(CODE,U)'=134) S ^TMP($J,CODE)=RDATA
I $D(RMPRGEC)&($P(CODE,U)=138)!($P(CODE,U)=134) S ^TMP($J,$P(CODE,U),$$STAN^RMPR31U(+BLG))=RDATA
K RDATA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR7 3790 printed Oct 16, 2024@18:34:02 Page 2
RMPR7 ;PHX/JLT-PRINT LAB/RESTORATIONS WORKSHEET ;8/29/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
DATE SET %DT="XEA"
SET %DT("A")="Enter Date to Start AMIS 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 KILL RMPRE
SET DIC="^RMPR(663,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select AMIS Line Item or <RETURN> for all: "
SET DIC("S")="S ZVAR=$P(^(0),U,4) I ZVAR=""O""!(ZVAR=""OR"")!(ZVAR=""R"")!(ZVAR=""RR"")"
+5 DO ^DIC
if (X["^")!$DATA(DTOUT)
GOTO EXIT
KILL DIC
IF Y>0
SET RMPRE=+Y
DEV SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO EXIT
KILL IOP
IF $EXTRACT(IOST,1,2)["C-"
GOTO FIND
+1 IF $DATA(IO("Q"))
Begin DoDot:1
+2 SET ZTIO=ION
SET ZTSAVE("RMPRSITE")=""
SET ZTSAVE("RMPR(")=""
SET ZTSAVE("DATE(")=""
SET ZTRTN="FIND^RMPR7"
SET ZTDESC="Prosthetic LAB or RESTORATIONS AMIS"
DO ^%ZTLOAD
KILL ZTDESC,ZTIO,ZTRTN,ZTSAVE
End DoDot:1
GOTO EXIT
FIND ;Entry Point to calculate Amis
+1 USE IO
KILL ^TMP($JOB)
+2 SET RMPRDT=DATE(1)-1
IF $DATA(RMPRGEC)
DO BLD^RMPR31U
+3 FOR
SET RMPRDT=$ORDER(^RMPR(660,"B",RMPRDT))
if RMPRDT>DATE(2)!(RMPRDT'>0)
QUIT
FOR RMPRBL=0:0
SET RMPRBL=$ORDER(^RMPR(660,"B",RMPRDT,RMPRBL))
if RMPRBL'>0
QUIT
SET BLG=$GET(^RMPR(660,RMPRBL,"LB"))
IF BLG'=""
Begin DoDot:1
+4 SET INF=$GET(^RMPR(660,RMPRBL,0))
SET RMPRAM=$GET(^("AM"))
+5 if RMPR("STA")'=$PIECE(BLG,U,4)
QUIT
if $PIECE(BLG,U,14)
QUIT
if $PIECE(BLG,U,11)&($PIECE(BLG,U,11)'>DATE(2))
QUIT
+6 IF $DATA(RMPRGEC)
SET PDZ=$GET(^RMPR(661,+$PIECE(INF,U,6),0))
IF PDZ
SET CODE=$$CODE^RMPR31U(PDZ,$PIECE(INF,U,4),$PIECE(BLG,U,3))
IF +CODE
if $PIECE(CODE,U)'=138&($PIECE(CODE,U)'=134)
DO BLG
+7 IF '$DATA(RMPRGEC)
SET RMPRWO=$PIECE($GET(^RMPR(664.2,+$PIECE(BLG,U,5),0)),U)
IF RMPRWO'=""
SET PDZ=$GET(^RMPR(661,+$PIECE(INF,U,6),0))
IF PDZ
SET CODE=$$CODE^RMPR31U(PDZ,$PIECE(INF,U,4),$PIECE(BLG,U,3))
IF +CODE
DO BLG
End DoDot:1
+8 SET RMPRDT=DATE(1)-1
+9 FOR
SET RMPRDT=$ORDER(^RMPR(660,"CD",RMPRDT))
if RMPRDT'>0!(RMPRDT>DATE(2))
QUIT
FOR RMPRBL=0:0
SET RMPRBL=$ORDER(^RMPR(660,"CD",RMPRDT,RMPRBL))
if RMPRBL'>0
QUIT
IF $DATA(^RMPR(660,RMPRBL,"LB"))
SET BLG=^("LB")
SET INF=$GET(^RMPR(660,RMPRBL,0))
SET RMPRAM=$GET(^("AM"))
Begin DoDot:1
+10 if RMPR("STA")'=$PIECE(BLG,U,4)
QUIT
if $PIECE(BLG,U,14)
QUIT
+11 IF $DATA(RMPRGEC)
SET PDZ=$GET(^RMPR(661,+$PIECE(INF,U,6),0))
IF PDZ
SET CODE=$$CODE^RMPR31U(PDZ,$PIECE(INF,U,4),$PIECE(BLG,U,3))
IF +CODE
DO COM
+12 IF '$DATA(RMPRGEC)
SET RMPRWO=$PIECE($GET(^RMPR(664.2,+$PIECE(BLG,U,5),0)),U)
IF RMPRWO'=""
SET PDZ=$GET(^RMPR(661,+$PIECE(INF,U,6),0))
IF PDZ
SET CODE=$$CODE^RMPR31U(PDZ,$PIECE(INF,U,4),$PIECE(BLG,U,3))
IF +CODE
DO COM
End DoDot:1
+13 IF $DATA(^TMP($JOB))
IF '$DATA(RMPRGEC)
DO ^RMPR71
EXIT if $DATA(RMPRGEC)
QUIT
KILL ^TMP($JOB)
DO ^%ZISC
NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
QUIT
BLG if '$DATA(RMPRGEC)
SET RDATA=$GET(^TMP($JOB,CODE,RMPRDT,RMPRWO))
if $DATA(RMPRGEC)
SET RDATA=$GET(^TMP($JOB,CODE))
+1 SET $PIECE(RDATA,U)=$PIECE(BLG,U)
+2 SET $PIECE(RDATA,U,9)=$PIECE(RDATA,U,9)+$PIECE(INF,U,7)
SET $PIECE(RDATA,U,10)=$PIECE(RDATA,U,10)+$PIECE($PIECE(BLG,U,6),".")
SET $PIECE(RDATA,U,11)=$PIECE(RDATA,U,11)+$PIECE($PIECE(BLG,U,6),".",2)
SET $PIECE(RDATA,U,12)=$PIECE(RDATA,U,12)+$PIECE(BLG,U,9)
+3 IF '$DATA(RMPRGEC)
SET ^TMP($JOB,CODE,RMPRDT,RMPRWO)=RDATA
+4 IF $DATA(RMPRGEC)
SET ^TMP($JOB,CODE)=RDATA
+5 KILL RDATA
+6 QUIT
COM IF '$DATA(RMPRGEC)
SET RDATA=$GET(^TMP($JOB,CODE,RMPRDT,RMPRWO))
+1 IF $DATA(RMPRGEC)&($PIECE(CODE,U)'=138)&($PIECE(CODE,U)'=134)
SET RDATA=$GET(^TMP($JOB,CODE))
+2 IF $DATA(RMPRGEC)&($PIECE(CODE,U)=138)!($PIECE(CODE,U)=134)
SET RDATA=$GET(^TMP($JOB,$PIECE(CODE,U),$$STAN^RMPR31U(+BLG)))
+3 SET $PIECE(RDATA,U)=$PIECE(BLG,U)
+4 SET $PIECE(RDATA,U,2)=$PIECE(RDATA,U,2)+$PIECE(INF,U,7)
+5 IF '$DATA(RMPRGEC)
if $PIECE(RMPRAM,U,3)<3
SET $PIECE(RDATA,U,3)=1
if $PIECE(RMPRAM,U,3)>2
SET $PIECE(RDATA,U,4)=1
+6 IF $DATA(RMPRGEC)
if $PIECE(RMPRAM,U,3)<3
SET $PIECE(RDATA,U,3)=$PIECE(RDATA,U,3)+1
if $PIECE(RMPRAM,U,3)>2
SET $PIECE(RDATA,U,4)=$PIECE(RDATA,U,4)+1
+7 SET $PIECE(RDATA,U,5)=$PIECE(RDATA,U,5)+$PIECE(BLG,U,8)
SET $PIECE(RDATA,U,6)=$PIECE(RDATA,U,6)+$PIECE($PIECE(BLG,U,6),".")
SET $PIECE(RDATA,U,7)=$PIECE(RDATA,U,7)+$PIECE($PIECE(BLG,U,6),".",2)
SET $PIECE(RDATA,U,8)=$PIECE(RDATA,U,8)+$PIECE(BLG,U,7)
+8 IF '$DATA(RMPRGEC)
SET ^TMP($JOB,CODE,RMPRDT,RMPRWO)=RDATA
+9 IF $DATA(RMPRGEC)&($PIECE(CODE,U)'=138)&($PIECE(CODE,U)'=134)
SET ^TMP($JOB,CODE)=RDATA
+10 IF $DATA(RMPRGEC)&($PIECE(CODE,U)=138)!($PIECE(CODE,U)=134)
SET ^TMP($JOB,$PIECE(CODE,U),$$STAN^RMPR31U(+BLG))=RDATA
+11 KILL RDATA
+12 QUIT
