source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR7.m@ 677

Last change on this file since 677 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.7 KB
Line 
1RMPR7 ;PHX/JLT-PRINT LAB/RESTORATIONS WORKSHEET ;8/29/1994
2 ;;3.0;PROSTHETICS;;Feb 09, 1996
3 D DIV4^RMPRSIT G:$D(X) EXIT
4DATE S %DT="XEA",%DT("A")="Enter Date to Start AMIS Calculations From: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT
5 S DATE(1)=+Y
6 S %DT="XEA",%DT("A")="Enter End Date: " D ^%DT G:X[U!(X="")!($D(DTOUT)) EXIT S DATE(2)=+Y
7 I DATE(1)>DATE(2) W !!,$C(7),"ENDING DATE RANGE IS LESS THAN BEGINNING DATE RANGE",! G DATE
8 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"")"
9 D ^DIC G:(X["^")!$D(DTOUT) EXIT K DIC I Y>0 S RMPRE=+Y
10DEV S %ZIS="MQ" D ^%ZIS G:POP EXIT K IOP I $E(IOST,1,2)["C-" G FIND
11 I $D(IO("Q")) D G EXIT
12 .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
13FIND ;Entry Point to calculate Amis
14 U IO K ^TMP($J)
15 S RMPRDT=DATE(1)-1 I $D(RMPRGEC) D BLD^RMPR31U
16 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
17 .S INF=$G(^RMPR(660,RMPRBL,0)),RMPRAM=$G(^("AM"))
18 .Q:RMPR("STA")'=$P(BLG,U,4) Q:$P(BLG,U,14) Q:$P(BLG,U,11)&($P(BLG,U,11)'>DATE(2))
19 .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
20 .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
21 S RMPRDT=DATE(1)-1
22 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
23 .Q:RMPR("STA")'=$P(BLG,U,4) Q:$P(BLG,U,14)
24 .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
25 .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
26 I $D(^TMP($J)),'$D(RMPRGEC) D ^RMPR71
27EXIT Q:$D(RMPRGEC) K ^TMP($J) D ^%ZISC N RMPR,RMPRSITE D KILL^XUSCLEAN Q
28BLG S:'$D(RMPRGEC) RDATA=$G(^TMP($J,CODE,RMPRDT,RMPRWO)) S:$D(RMPRGEC) RDATA=$G(^TMP($J,CODE))
29 S $P(RDATA,U)=$P(BLG,U)
30 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)
31 I '$D(RMPRGEC) S ^TMP($J,CODE,RMPRDT,RMPRWO)=RDATA
32 I $D(RMPRGEC) S ^TMP($J,CODE)=RDATA
33 K RDATA
34 Q
35COM I '$D(RMPRGEC) S RDATA=$G(^TMP($J,CODE,RMPRDT,RMPRWO))
36 I $D(RMPRGEC)&($P(CODE,U)'=138)&($P(CODE,U)'=134) S RDATA=$G(^TMP($J,CODE))
37 I $D(RMPRGEC)&($P(CODE,U)=138)!($P(CODE,U)=134) S RDATA=$G(^TMP($J,$P(CODE,U),$$STAN^RMPR31U(+BLG)))
38 S $P(RDATA,U)=$P(BLG,U)
39 S $P(RDATA,U,2)=$P(RDATA,U,2)+$P(INF,U,7)
40 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
41 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
42 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)
43 I '$D(RMPRGEC) S ^TMP($J,CODE,RMPRDT,RMPRWO)=RDATA
44 I $D(RMPRGEC)&($P(CODE,U)'=138)&($P(CODE,U)'=134) S ^TMP($J,CODE)=RDATA
45 I $D(RMPRGEC)&($P(CODE,U)=138)!($P(CODE,U)=134) S ^TMP($J,$P(CODE,U),$$STAN^RMPR31U(+BLG))=RDATA
46 K RDATA
47 Q
Note: See TracBrowser for help on using the repository browser.