- RMPRCT ;PHX/HNB-INPUT TRANSFORM ITEM COST/10-2421 ;10/19/1993
- ;;3.0;PROSTHETICS;**25**;Feb 09, 1996
- EN I X'?.N.1".".2N!(X<0)!(X>999999.99) K X Q
- I '$D(RMPRF) Q
- Q:(RMPRF=1) G:(RMPRF=2)!(RMPRF=9) AR G:'$D(RMPRAMT) CON
- S PQTY=$S($P(^RMPR(664,DA(1),1,DA,0),U,4):$P(^(0),U,4),1:1)
- 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
- 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"
- I W !,"This Form Type will be CHANGED to a 10-55" K X S RMPR90=1
- I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,3)=X
- Q
- CON Q
- AR ;10-2421 and No Form
- S (RMPRY,RMPRX)=0
- F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
- I RMPRY=0 S RMPRX=$P(^RMPR(664,DA(1),1,DA,0),U,4)*X G ARE
- S PCST=$P(^RMPR(664,DA(1),1,DA,0),U,3),PQTY=$P(^RMPR(664,DA(1),1,DA,0),U,4)
- I 'PCST S RMPRX=RMPRY+(PQTY*X)
- I PCST S RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
- W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This Amount is $"_RMPRX
- ARE I $D(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0)) D WR Q
- I '$D(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0)) D WR Q
- I $D(X),RMPRF="E",$D(RMX) S $P(^RMPR(664,DA(1),1,DA,0),U,7)=X
- K RMPRX,RMPRY,PCST,PQTY,RI,RMPR660,PACST,RMPR90,RMX Q
- WR W $C(7),!!,?5,"Dollar Amount must be within Contract Authority Guidelines",! Q
- EN1 ;Check for PSC card issue and Eyeglass items
- Q:'$D(RMPRF) G:RMPRF["E" EN3
- 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
- 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
- Q:(RMPRF'=1)&(RMPRF'=10) S RMPRUP=0 S RMPRUP=$O(^RMPR(665,"C",X,RMPRDFN,RMPRUP))
- W:RMPRUP="" !,$C(7),"*** THIS PATIENT DOES NOT HAVE A PSC CARD FOR THIS ITEM YET!***" K:RMPRUP="" X
- Q
- EN3 ;INPUT TRANSFORM TO NOT ALLOW ITEMS ENTERED
- K X W !,$C(7),"YOU MAY NOT CHANGE ITEMS AT THIS TIME!" Q
- 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
- 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
- Q
- ITM ;Check item QTY and Cost
- I +X'=X!(X>300)!(X?.E1"."1N.N) K X Q
- I '$D(RMPRF) Q
- I '$P(^RMPR(664,DA(1),1,DA,0),U,3) Q
- 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
- 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)
- 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
- I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,4)=X
- Q
- TAR S (RMPRY,RMPRX)=0
- F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
- I RMPRY=0 G ARE
- 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
- S:+PACST PCST=PACST I 'PQTY S RMPRX=RMPRY+(PCST*X)
- I PQTY,PCST S RMPRX=RMPRY-(PCST*PQTY)+(PCST*X)
- W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This number of Items is $"_RMPRX
- G ARE
- ACT ;Check Actual cost for item
- S:X["$" X=$P(X,"$",2) I X'?.N.1".".2N!(X>999999)!(X<0) K X Q
- I '$D(RMPRF) Q
- 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
- 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
- I $D(X) S $P(^RMPR(664,DA(1),1,DA,0),U,7)=X
- Q
- SAR S (RMPRY,RMPRX)=0,RMX=1
- F RI=0:0 S RI=$O(^RMPR(664,DA(1),1,RI)) Q:RI'>0 D CHK
- 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
- I 'PACST S RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
- I PACST S RMPRX=RMPRY-(PACST*PQTY)+(PQTY*X)
- W !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total with this actual amount is $"_RMPRX
- G ARE
- CHECK ;CHECK PURCHASE FOR CONTRACT NUMBER AND COST
- I RMPRF="E" I $D(RMPRP),(RMPRP["PSC"!(RMPRP["2520")) Q
- I RMPRF=10!(RMPRF=1) Q
- I $D(RMPRCONT)&(RMPRTO>999999) K RMPRTO
- I '$D(RMPRCONT)&(RMPRTO>999999) K RMPRTO
- I '$D(RMPRTO) W !!,$C(7),?5,"Dollar Amount must be within Contract Authority Guidelines",! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRCT 4614 printed Feb 19, 2025@00:00:36 Page 2
- RMPRCT ;PHX/HNB-INPUT TRANSFORM ITEM COST/10-2421 ;10/19/1993
- +1 ;;3.0;PROSTHETICS;**25**;Feb 09, 1996
- EN IF X'?.N.1".".2N!(X<0)!(X>999999.99)
- KILL X
- QUIT
- +1 IF '$DATA(RMPRF)
- QUIT
- +2 if (RMPRF=1)
- QUIT
- if (RMPRF=2)!(RMPRF=9)
- GOTO AR
- if '$DATA(RMPRAMT)
- GOTO CON
- +3 SET PQTY=$SELECT($PIECE(^RMPR(664,DA(1),1,DA,0),U,4):$PIECE(^(0),U,4),1:1)
- +4 IF RMPRF=10&($DATA(RMPR90))&(X*PQTY>RMPRAMT)
- SET RMPRF=1
- KILL RMPRPSC
- WRITE !,$CHAR(7),$CHAR(7),"This Form Type Has Been Changed to a 10-55!"
- QUIT
- +5 IF $DATA(RMPRAMT)
- IF X*PQTY>RMPRAMT
- WRITE !,$CHAR(7),$CHAR(7),"You Can Not Exceed $",$JUSTIFY(RMPRAMT,0,2),", You Must Issue a 10-55 For This Amount!",!,"If You Enter in an Amount That Exceeds the Above Amount"
- +6 IF $TEST
- WRITE !,"This Form Type will be CHANGED to a 10-55"
- KILL X
- SET RMPR90=1
- +7 IF $DATA(X)
- SET $PIECE(^RMPR(664,DA(1),1,DA,0),U,3)=X
- +8 QUIT
- CON QUIT
- AR ;10-2421 and No Form
- +1 SET (RMPRY,RMPRX)=0
- +2 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664,DA(1),1,RI))
- if RI'>0
- QUIT
- DO CHK
- +3 IF RMPRY=0
- SET RMPRX=$PIECE(^RMPR(664,DA(1),1,DA,0),U,4)*X
- GOTO ARE
- +4 SET PCST=$PIECE(^RMPR(664,DA(1),1,DA,0),U,3)
- SET PQTY=$PIECE(^RMPR(664,DA(1),1,DA,0),U,4)
- +5 IF 'PCST
- SET RMPRX=RMPRY+(PQTY*X)
- +6 IF PCST
- SET RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
- +7 WRITE !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This Amount is $"_RMPRX
- ARE IF $DATA(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0))
- DO WR
- QUIT
- +1 IF '$DATA(RMPRCONT)&(RMPRX>999999!(X>999999)!(X'?.N.1".".2N)!(X<0))
- DO WR
- QUIT
- +2 IF $DATA(X)
- IF RMPRF="E"
- IF $DATA(RMX)
- SET $PIECE(^RMPR(664,DA(1),1,DA,0),U,7)=X
- +3 KILL RMPRX,RMPRY,PCST,PQTY,RI,RMPR660,PACST,RMPR90,RMX
- QUIT
- WR WRITE $CHAR(7),!!,?5,"Dollar Amount must be within Contract Authority Guidelines",!
- QUIT
- EN1 ;Check for PSC card issue and Eyeglass items
- +1 if '$DATA(RMPRF)
- QUIT
- if RMPRF["E"
- GOTO EN3
- +2 IF RMPRF=8
- SET R90=$PIECE(^RMPR(661,X,0),U,3)
- SET RI=$PIECE(^RMPR(661,X,0),U,4)
- if (+R90=0)!(+RI=0)
- KILL X
- +3 IF $TEST
- IF (+R90)&(+RI)
- IF $PIECE(^RMPR(663,R90,0),U,1)'=11
- IF $PIECE(^RMPR(663,RI,0),U,1)'="R06"
- WRITE !,$CHAR(7),"*** THIS ITEM HAS IMPROPER AMIS CODES AND CANNOT BE ENTERED ON A 2914"
- KILL X
- +4 if (RMPRF'=1)&(RMPRF'=10)
- QUIT
- SET RMPRUP=0
- SET RMPRUP=$ORDER(^RMPR(665,"C",X,RMPRDFN,RMPRUP))
- +5 if RMPRUP=""
- WRITE !,$CHAR(7),"*** THIS PATIENT DOES NOT HAVE A PSC CARD FOR THIS ITEM YET!***"
- if RMPRUP=""
- KILL X
- +6 QUIT
- EN3 ;INPUT TRANSFORM TO NOT ALLOW ITEMS ENTERED
- +1 KILL X
- WRITE !,$CHAR(7),"YOU MAY NOT CHANGE ITEMS AT THIS TIME!"
- QUIT
- CHK IF $PIECE(^RMPR(664,DA(1),1,RI,0),U,4)&($PIECE(^(0),U,7))
- SET RMPRY=RMPRY+($PIECE(^(0),U,4)*$PIECE(^(0),U,7))
- QUIT
- +1 IF $PIECE(^RMPR(664,DA(1),1,RI,0),U,4)&($PIECE(^(0),U,3))
- SET RMPRY=RMPRY+($PIECE(^(0),U,3)*$PIECE(^(0),U,4))
- QUIT
- +2 QUIT
- ITM ;Check item QTY and Cost
- +1 IF +X'=X!(X>300)!(X?.E1"."1N.N)
- KILL X
- QUIT
- +2 IF '$DATA(RMPRF)
- QUIT
- +3 IF '$PIECE(^RMPR(664,DA(1),1,DA,0),U,3)
- QUIT
- +4 if (RMPRF=1)
- QUIT
- if (RMPRF=2)!(RMPRF=9)
- GOTO TAR
- SET RMPR660=$PIECE(^RMPR(664,DA(1),1,DA,0),U,13)
- if +RMPR660
- SET RMPR660=$PIECE(^RMPR(660,RMPR660,0),U,13)
- if (RMPR660=2)!(RMPR660=9)
- GOTO TAR
- if '$DATA(RMPRAMT)
- GOTO CON
- +5 SET RMPRY=$SELECT($PIECE(^RMPR(664,DA(1),1,DA,0),U,7):X*$PIECE(^(0),U,7),1:+$PIECE(^RMPR(664,DA(1),1,DA,0),U,3)*X)
- +6 IF (RMPRF=10)!(RMPRF="E")
- IF RMPRY>RMPRAMT
- WRITE !!,?5,"This will change the amount on this FORM to ","$ ",$JUSTIFY(RMPRY,0,2)
- WRITE $CHAR(7),!,?5,"Cost cannot exceed ","$ ",$JUSTIFY(RMPRAMT,0,2)
- KILL X
- +7 IF $DATA(X)
- SET $PIECE(^RMPR(664,DA(1),1,DA,0),U,4)=X
- +8 QUIT
- TAR SET (RMPRY,RMPRX)=0
- +1 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664,DA(1),1,RI))
- if RI'>0
- QUIT
- DO CHK
- +2 IF RMPRY=0
- GOTO ARE
- +3 SET PCST=$PIECE(^RMPR(664,DA(1),1,DA,0),U,3)
- SET PACST=$PIECE(^(0),U,7)
- SET PQTY=$PIECE(^RMPR(664,DA(1),1,DA,0),U,4)
- IF $PIECE(^(0),U,14)'=""
- SET RMPRCONT=1
- +4 if +PACST
- SET PCST=PACST
- IF 'PQTY
- SET RMPRX=RMPRY+(PCST*X)
- +5 IF PQTY
- IF PCST
- SET RMPRX=RMPRY-(PCST*PQTY)+(PCST*X)
- +6 WRITE !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total With This number of Items is $"_RMPRX
- +7 GOTO ARE
- ACT ;Check Actual cost for item
- +1 if X["$"
- SET X=$PIECE(X,"$",2)
- IF X'?.N.1".".2N!(X>999999)!(X<0)
- KILL X
- QUIT
- +2 IF '$DATA(RMPRF)
- QUIT
- +3 if (RMPRF=1)
- QUIT
- if (RMPRF=2)!(RMPRF=9)
- GOTO SAR
- SET RMPR660=$PIECE(^RMPR(664,DA(1),1,DA,0),U,13)
- if +RMPR660
- SET RMPR660=$PIECE(^RMPR(660,RMPR660,0),U,13)
- if (RMPR660=2)!(RMPR660=9)
- GOTO SAR
- if '$DATA(RMPRAMT)
- GOTO CON
- +4 IF (RMPRF="E")&$DATA(RMPRAMT)
- IF $PIECE(^RMPR(664,DA(1),DA,1,0),U,4)*X>RMPRAMT
- WRITE !,$CHAR(7),$CHAR(7),"You Can Not Exceed $",$JUSTIFY(RMPRAMT,0,2)," For This 2520 Form."
- KILL X
- +5 IF $DATA(X)
- SET $PIECE(^RMPR(664,DA(1),1,DA,0),U,7)=X
- +6 QUIT
- SAR SET (RMPRY,RMPRX)=0
- SET RMX=1
- +1 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664,DA(1),1,RI))
- if RI'>0
- QUIT
- DO CHK
- +2 SET PACST=$PIECE(^RMPR(664,DA(1),1,DA,0),U,7)
- SET PCST=$PIECE(^(0),U,3)
- SET PQTY=$PIECE(^(0),U,4)
- if $PIECE(^(0),U,14)'=""
- SET RMPRCONT=1
- +3 IF 'PACST
- SET RMPRX=RMPRY-(PCST*PQTY)+(PQTY*X)
- +4 IF PACST
- SET RMPRX=RMPRY-(PACST*PQTY)+(PQTY*X)
- +5 WRITE !,?5,"** Total for Previous Item(s) is $"_RMPRY,!,?5,"** Total with this actual amount is $"_RMPRX
- +6 GOTO ARE
- CHECK ;CHECK PURCHASE FOR CONTRACT NUMBER AND COST
- +1 IF RMPRF="E"
- IF $DATA(RMPRP)
- IF (RMPRP["PSC"!(RMPRP["2520"))
- QUIT
- +2 IF RMPRF=10!(RMPRF=1)
- QUIT
- +3 IF $DATA(RMPRCONT)&(RMPRTO>999999)
- KILL RMPRTO
- +4 IF '$DATA(RMPRCONT)&(RMPRTO>999999)
- KILL RMPRTO
- +5 IF '$DATA(RMPRTO)
- WRITE !!,$CHAR(7),?5,"Dollar Amount must be within Contract Authority Guidelines",!
- QUIT
