[613] | 1 | RMPRCT ;PHX/HNB-INPUT TRANSFORM ITEM COST/10-2421 ;10/19/1993
|
---|
| 2 | ;;3.0;PROSTHETICS;**25**;Feb 09, 1996
|
---|
| 3 | EN I X'?.N.1".".2N!(X<0)!(X>999999.99) K X Q
|
---|
| 4 | I '$D(RMPRF) Q
|
---|
| 5 | Q:(RMPRF=1) G:(RMPRF=2)!(RMPRF=9) AR G:'$D(RMPRAMT) CON
|
---|
| 6 | S PQTY=$S($P(^RMPR(664,DA(1),1,DA,0),U,4):$P(^(0),U,4),1:1)
|
---|
| 7 | I RMPRF=10&($D(RMPR90))&(X*PQTY>RMPRAMT) S RMPRF=1 K RMPRPSC W !,$C(7),$C(7),"This Form Type Has Been Changed to a 10-55!" Q
|
---|
| 8 | I $D(RMPRAMT) I X*PQTY>RMPRAMT W !,$C(7),$C(7),"You Can Not Exceed $",$J(RMPRAMT,0,2),", You Must Issue a 10-55 For This Amount!",!,"If You Enter in an Amount That Exceeds the Above Amount"
|
---|
| 9 | I W !,"This Form Type will be CHANGED to a 10-55" K X S RMPR90=1
|
---|
| 10 | I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,3)=X
|
---|
| 11 | Q
|
---|
| 12 | CON Q
|
---|
| 13 | AR ;10-2421 and No Form
|
---|
| 14 | S (RMPRY,RMPRX)=0
|
---|
| 15 | F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
|
---|
| 16 | I RMPRY=0 S RMPRX=$P(^RMPR(664,DA(1),1,DA,0),U,4)*X G ARE
|
---|
| 17 | S PCST=$P(^RMPR(664,DA(1),1,DA,0),U,3),PQTY=$P(^RMPR(664,DA(1),1,DA,0),U,4)
|
---|
| 18 | I 'PCST S RMPRX=RMPRY+(PQTY*X)
|
---|
| 19 | I PCST S RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
|
---|
| 20 | W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This Amount is $"_RMPRX
|
---|
| 21 | ARE I $D(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0)) D WR Q
|
---|
| 22 | I '$D(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0)) D WR Q
|
---|
| 23 | I $D(X),RMPRF="E",$D(RMX) S $P(^RMPR(664,DA(1),1,DA,0),U,7)=X
|
---|
| 24 | K RMPRX,RMPRY,PCST,PQTY,RI,RMPR660,PACST,RMPR90,RMX Q
|
---|
| 25 | WR W $C(7),!!,?5,"Dollar Amount must be within Contract Authority Guidelines",! Q
|
---|
| 26 | EN1 ;Check for PSC card issue and Eyeglass items
|
---|
| 27 | Q:'$D(RMPRF) G:RMPRF["E" EN3
|
---|
| 28 | I RMPRF=8 S R90=$P(^RMPR(661,X,0),U,3),RI=$P(^RMPR(661,X,0),U,4) K:(+R90=0)!(+RI=0) X
|
---|
| 29 | I I (+R90)&(+RI) I $P(^RMPR(663,R90,0),U,1)'=11,$P(^RMPR(663,RI,0),U,1)'="R06" W !,$C(7),"*** THIS ITEM HAS IMPROPER AMIS CODES AND CANNOT BE ENTERED ON A 2914" K X
|
---|
| 30 | Q:(RMPRF'=1)&(RMPRF'=10) S RMPRUP=0 S RMPRUP=$O(^RMPR(665,"C",X,RMPRDFN,RMPRUP))
|
---|
| 31 | W:RMPRUP="" !,$C(7),"*** THIS PATIENT DOES NOT HAVE A PSC CARD FOR THIS ITEM YET!***" K:RMPRUP="" X
|
---|
| 32 | Q
|
---|
| 33 | EN3 ;INPUT TRANSFORM TO NOT ALLOW ITEMS ENTERED
|
---|
| 34 | K X W !,$C(7),"YOU MAY NOT CHANGE ITEMS AT THIS TIME!" Q
|
---|
| 35 | CHK I $P(^RMPR(664,DA(1),1,RI,0),U,4)&($P(^(0),U,7)) S RMPRY=RMPRY+($P(^(0),U,4)*$P(^(0),U,7)) Q
|
---|
| 36 | I $P(^RMPR(664,DA(1),1,RI,0),U,4)&($P(^(0),U,3)) S RMPRY=RMPRY+($P(^(0),U,3)*$P(^(0),U,4)) Q
|
---|
| 37 | Q
|
---|
| 38 | ITM ;Check item QTY and Cost
|
---|
| 39 | I +X'=X!(X>300)!(X?.E1"."1N.N) K X Q
|
---|
| 40 | I '$D(RMPRF) Q
|
---|
| 41 | I '$P(^RMPR(664,DA(1),1,DA,0),U,3) Q
|
---|
| 42 | Q:(RMPRF=1) G:(RMPRF=2)!(RMPRF=9) TAR S RMPR660=$P(^RMPR(664,DA(1),1,DA,0),U,13) S:+RMPR660 RMPR660=$P(^RMPR(660,RMPR660,0),U,13) G:(RMPR660=2)!(RMPR660=9) TAR G:'$D(RMPRAMT) CON
|
---|
| 43 | S RMPRY=$S($P(^RMPR(664,DA(1),1,DA,0),U,7):X*$P(^(0),U,7),1:+$P(^RMPR(664,DA(1),1,DA,0),U,3)*X)
|
---|
| 44 | I (RMPRF=10)!(RMPRF="E") I RMPRY>RMPRAMT W !!,?5,"This will change the amount on this FORM to ","$ ",$J(RMPRY,0,2) W $C(7),!,?5,"Cost cannot exceed ","$ ",$J(RMPRAMT,0,2) K X
|
---|
| 45 | I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,4)=X
|
---|
| 46 | Q
|
---|
| 47 | TAR S (RMPRY,RMPRX)=0
|
---|
| 48 | F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
|
---|
| 49 | I RMPRY=0 G ARE
|
---|
| 50 | S PCST=$P(^RMPR(664,DA(1),1,DA,0),U,3),PACST=$P(^(0),U,7),PQTY=$P(^RMPR(664,DA(1),1,DA,0),U,4) I $P(^(0),U,14)'="" S RMPRCONT=1
|
---|
| 51 | S:+PACST PCST=PACST I 'PQTY S RMPRX=RMPRY+(PCST*X)
|
---|
| 52 | I PQTY,PCST S RMPRX=RMPRY-(PCST*PQTY)+(PCST*X)
|
---|
| 53 | W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This number of Items is $"_RMPRX
|
---|
| 54 | G ARE
|
---|
| 55 | ACT ;Check Actual cost for item
|
---|
| 56 | S:X["$" X=$P(X,"$",2) I X'?.N.1".".2N!(X>999999)!(X<0) K X Q
|
---|
| 57 | I '$D(RMPRF) Q
|
---|
| 58 | Q:(RMPRF=1) G:(RMPRF=2)!(RMPRF=9) SAR S RMPR660=$P(^RMPR(664,DA(1),1,DA,0),U,13) S:+RMPR660 RMPR660=$P(^RMPR(660,RMPR660,0),U,13) G:(RMPR660=2)!(RMPR660=9) SAR G:'$D(RMPRAMT) CON
|
---|
| 59 | I (RMPRF="E")&$D(RMPRAMT) I $P(^RMPR(664,DA(1),DA,1,0),U,4)*X>RMPRAMT W !,$C(7),$C(7),"You Can Not Exceed $",$J(RMPRAMT,0,2)," For This 2520 Form." K X
|
---|
| 60 | I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,7)=X
|
---|
| 61 | Q
|
---|
| 62 | SAR S (RMPRY,RMPRX)=0,RMX=1
|
---|
| 63 | F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
|
---|
| 64 | S PACST=$P(^RMPR(664,DA(1),1,DA,0),U,7),PCST=$P(^(0),U,3),PQTY=$P(^(0),U,4) S:$P(^(0),U,14)'="" RMPRCONT=1
|
---|
| 65 | I 'PACST S RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
|
---|
| 66 | I PACST S RMPRX=RMPRY-(PACST*PQTY)+(PQTY*X)
|
---|
| 67 | W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total with this actual amount is $"_RMPRX
|
---|
| 68 | G ARE
|
---|
| 69 | CHECK ;CHECK PURCHASE FOR CONTRACT NUMBER AND COST
|
---|
| 70 | I RMPRF="E" I $D(RMPRP),(RMPRP["PSC"!(RMPRP["2520")) Q
|
---|
| 71 | I RMPRF=10!(RMPRF=1) Q
|
---|
| 72 | I $D(RMPRCONT)&(RMPRTO>999999) K RMPRTO
|
---|
| 73 | I '$D(RMPRCONT)&(RMPRTO>999999) K RMPRTO
|
---|
| 74 | I '$D(RMPRTO) W !!,$C(7),?5,"Dollar Amount must be within Contract Authority Guidelines",! Q
|
---|