- RMPRLI ;PHX/HNB,RVD-DISPLAY ITEMS ON 1358 TRANSACTION ;10/19/1993
- ;;3.0;PROSTHETICS;**12,19,28,41,90**;Feb 09, 1996
- ;pass RMPRSSN,RMPRNAM,RMPRA,RMPROB
- S:'$D(RMPRDELN) RMPRDELN="" S (RMPRI,RMPRCNT)=0,RMPRX="" D HOME^%ZIS W @IOF S:'$D(RMPRSER) RMPRSER=""
- W !?5,RMPRNAM,?35,$E(RMPRSSN,1,3)_"-"_$E(RMPRSSN,4,5)_"-"_$E(RMPRSSN,6,9),?55,RMPROB,!
- N RBO S RBO=0
- W !,RMPR("L")
- LI F S RMPRI=$O(^RMPR(664,RMPRA,1,RMPRI)) Q:RMPRI'>0 D G:$G(RMPRX)["^" EXIT
- .S RMPRCNT=RMPRCNT+1
- .S RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0)
- .D PRT
- I $D(^RMPR(664,RMPRA,1)) W !!,?25,"SUB TOTAL: ",?65,"$",$J(RBO,7,2)
- I $D(^RMPR(664,RMPRA,2)),$P(^(2),U,6) S DCT=$P(^(2),U,6),DCT=DCT/100
- I $D(RMPRF) I ((RMPRF=9)!(RMPRF=2)!(RMPRF="E")),$D(^RMPR(664,RMPRA,1)) D
- .W !!,?25,"% DISCOUNT: "
- .Q:'$D(DCT)
- .W DCT*100
- .S DCTT=$J(RBO*DCT,7,2)
- .W ?65,"$",DCTT
- .S DCTT=$TR(DCTT," ","")
- .S RBO=RBO-DCTT
- .K DCT,DCTT
- W !?25,"SHIPPING CHARGE: "
- S R2=$S($P(^RMPR(664,RMPRA,0),U,11)]"":$P(^(0),U,11),$P(^(0),U,10):$P(^(0),U,10),1:"") W ?65,"$",$J(R2,7,2) W !
- W !,?25,"TOTAL COST: ",?65,"$",$J(R2+RBO,7,2)
- G EXIT
- PRT I RMPRCNT<0 W !,"NO ITEMS ON FILE" Q
- W !!?5,"ITEM: "
- S RMPRIT=$P(RMPRI1,U,1),RMPRIT1=$P(^RMPR(661,RMPRIT,0),U,1)
- W $P(^PRC(441,RMPRIT1,0),U,1)," ",$P(^(0),U,2)," ",?45,"AMIS: " S RMPRAMIS=$S($P(RMPRI1,U,9)'="X":$P(^RMPR(661,RMPRIT,0),U,3),1:$P(^RMPR(661,RMPRIT,0),U,4))
- W $S(RMPRAMIS="":"NO CODE FOR THIS ITEM",1:$P(^RMPR(663,RMPRAMIS,0),U,1))
- S RCPT=$P(^RMPR(664,RMPRA,1,RMPRI,0),U,16)
- S:RCPT RMPRCPT=$G(^RMPR(661.1,RCPT,0))
- I $D(RMPRCPT) W !,?5,"PSAS HCPCS CODE: ",$P(RMPRCPT,U,1),?29,$P(RMPRCPT,U,2)
- W !,?5,"CPT MODIFIER: ",$P($G(^RMPR(664,RMPRA,1,RMPRI,4)),U,2)
- K RCPT,RMPRCPT
- I $P(^RMPR(664,RMPRA,1,RMPRI,0),U,8)'="" W !?5,"REMARKS: ",$P(^(0),U,8)
- I $D(RMPRF),RMPRF=2 W !!?5,"DELIVER TO: ",RMPRDELN
- W !!?5,"DESCRIPTION: ",$P(RMPRI1,U,2)
- W !?5,"SERIAL NUMBER: " S RMPRSER=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$P(^(0),U,15),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,11),1:"") W RMPRSER
- ;W !?5,"UNIT COST: ",$J($S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
- W !,?5,"UNIT COST: " S R1=$P(RMPRI1,U,7) S:R1=""!(R1<0) R1=$P(RMPRI1,U,3) W R1,?25,"UNIT OF ISSUE: "
- S RMPRU=$P(RMPRI1,U,5) W:RMPRU'="" $P(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$P(RMPRI1,U,4),?55,"ITEM COST: "
- ;S R1=$S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),R2=$P(RMPRI1,U,4),RBO=RBO+(R1*R2) W $J(R1*R2,0,2)
- S R2=$P(RMPRI1,U,4)
- S RBO=RBO+(R1*R2) W $J(R1*R2,0,2)
- W !?5,"TYPE: ",$S($P(RMPRI1,U,9)="X":"REPAIR",$P(RMPRI1,U,9)="I":"INITIAL",$P(RMPRI1,U,9)="R":"REPLACE",$P(RMPRI1,U,9)="S":"SPARE",$P(RMPRI1,U,9)="5":"RENTAL",1:"")
- W ?25,"CATEGORY: ",$S($P(RMPRI1,U,10)=1:"SC/OP",$P(RMPRI1,U,10)=2:"SC/IP",$P(RMPRI1,U,10)=3:"NSC/IP",$P(RMPRI1,U,10)=4:"NSC/OP",1:"")
- W ?44,"SPECIAL CATEGORY: "
- W $S($P(RMPRI1,U,11)=1:"SPEC/LEG",$P(RMPRI1,U,11)=2:"A&A",$P(RMPRI1,U,11)=3:"PHC",$P(RMPRI1,U,11)=4:"ELIGIBILITY REFORM",1:"")
- ASK I $Y>17 R !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME S:'$T RMPRX="^" Q:RMPRX="^"
- W:$Y>17 @IOF
- Q
- EXIT K RMPRI1,R1,R2,ON,OFF Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRLI 3141 printed Jan 18, 2025@03:36:10 Page 2
- RMPRLI ;PHX/HNB,RVD-DISPLAY ITEMS ON 1358 TRANSACTION ;10/19/1993
- +1 ;;3.0;PROSTHETICS;**12,19,28,41,90**;Feb 09, 1996
- +2 ;pass RMPRSSN,RMPRNAM,RMPRA,RMPROB
- +3 if '$DATA(RMPRDELN)
- SET RMPRDELN=""
- SET (RMPRI,RMPRCNT)=0
- SET RMPRX=""
- DO HOME^%ZIS
- WRITE @IOF
- if '$DATA(RMPRSER)
- SET RMPRSER=""
- +4 WRITE !?5,RMPRNAM,?35,$EXTRACT(RMPRSSN,1,3)_"-"_$EXTRACT(RMPRSSN,4,5)_"-"_$EXTRACT(RMPRSSN,6,9),?55,RMPROB,!
- +5 NEW RBO
- SET RBO=0
- +6 WRITE !,RMPR("L")
- LI FOR
- SET RMPRI=$ORDER(^RMPR(664,RMPRA,1,RMPRI))
- if RMPRI'>0
- QUIT
- Begin DoDot:1
- +1 SET RMPRCNT=RMPRCNT+1
- +2 SET RMPRI1=^RMPR(664,RMPRA,1,RMPRI,0)
- +3 DO PRT
- End DoDot:1
- if $GET(RMPRX)["^"
- GOTO EXIT
- +4 IF $DATA(^RMPR(664,RMPRA,1))
- WRITE !!,?25,"SUB TOTAL: ",?65,"$",$JUSTIFY(RBO,7,2)
- +5 IF $DATA(^RMPR(664,RMPRA,2))
- IF $PIECE(^(2),U,6)
- SET DCT=$PIECE(^(2),U,6)
- SET DCT=DCT/100
- +6 IF $DATA(RMPRF)
- IF ((RMPRF=9)!(RMPRF=2)!(RMPRF="E"))
- IF $DATA(^RMPR(664,RMPRA,1))
- Begin DoDot:1
- +7 WRITE !!,?25,"% DISCOUNT: "
- +8 if '$DATA(DCT)
- QUIT
- +9 WRITE DCT*100
- +10 SET DCTT=$JUSTIFY(RBO*DCT,7,2)
- +11 WRITE ?65,"$",DCTT
- +12 SET DCTT=$TRANSLATE(DCTT," ","")
- +13 SET RBO=RBO-DCTT
- +14 KILL DCT,DCTT
- End DoDot:1
- +15 WRITE !?25,"SHIPPING CHARGE: "
- +16 SET R2=$SELECT($PIECE(^RMPR(664,RMPRA,0),U,11)]"":$PIECE(^(0),U,11),$PIECE(^(0),U,10):$PIECE(^(0),U,10),1:"")
- WRITE ?65,"$",$JUSTIFY(R2,7,2)
- WRITE !
- +17 WRITE !,?25,"TOTAL COST: ",?65,"$",$JUSTIFY(R2+RBO,7,2)
- +18 GOTO EXIT
- PRT IF RMPRCNT<0
- WRITE !,"NO ITEMS ON FILE"
- QUIT
- +1 WRITE !!?5,"ITEM: "
- +2 SET RMPRIT=$PIECE(RMPRI1,U,1)
- SET RMPRIT1=$PIECE(^RMPR(661,RMPRIT,0),U,1)
- +3 WRITE $PIECE(^PRC(441,RMPRIT1,0),U,1)," ",$PIECE(^(0),U,2)," ",?45,"AMIS: "
- SET RMPRAMIS=$SELECT($PIECE(RMPRI1,U,9)'="X":$PIECE(^RMPR(661,RMPRIT,0),U,3),1:$PIECE(^RMPR(661,RMPRIT,0),U,4))
- +4 WRITE $SELECT(RMPRAMIS="":"NO CODE FOR THIS ITEM",1:$PIECE(^RMPR(663,RMPRAMIS,0),U,1))
- +5 SET RCPT=$PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,16)
- +6 if RCPT
- SET RMPRCPT=$GET(^RMPR(661.1,RCPT,0))
- +7 IF $DATA(RMPRCPT)
- WRITE !,?5,"PSAS HCPCS CODE: ",$PIECE(RMPRCPT,U,1),?29,$PIECE(RMPRCPT,U,2)
- +8 WRITE !,?5,"CPT MODIFIER: ",$PIECE($GET(^RMPR(664,RMPRA,1,RMPRI,4)),U,2)
- +9 KILL RCPT,RMPRCPT
- +10 IF $PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,8)'=""
- WRITE !?5,"REMARKS: ",$PIECE(^(0),U,8)
- +11 IF $DATA(RMPRF)
- IF RMPRF=2
- WRITE !!?5,"DELIVER TO: ",RMPRDELN
- +12 WRITE !!?5,"DESCRIPTION: ",$PIECE(RMPRI1,U,2)
- +13 WRITE !?5,"SERIAL NUMBER: "
- SET RMPRSER=$SELECT($PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,15)]"":$PIECE(^(0),U,15),$DATA(^RMPR(660,+$PIECE(^(0),U,13),0)):$PIECE(^(0),U,11),1:"")
- WRITE RMPRSER
- +14 ;W !?5,"UNIT COST: ",$J($S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),0,2),?25,"UNIT OF ISSUE: "
- +15 WRITE !,?5,"UNIT COST: "
- SET R1=$PIECE(RMPRI1,U,7)
- if R1=""!(R1<0)
- SET R1=$PIECE(RMPRI1,U,3)
- WRITE R1,?25,"UNIT OF ISSUE: "
- +16 SET RMPRU=$PIECE(RMPRI1,U,5)
- if RMPRU'=""
- WRITE $PIECE(^PRCD(420.5,RMPRU,0),U,1),?45,"QTY: ",$PIECE(RMPRI1,U,4),?55,"ITEM COST: "
- +17 ;S R1=$S($P(RMPRI1,U,7):$P(RMPRI1,U,7),1:$P(RMPRI1,U,3)),R2=$P(RMPRI1,U,4),RBO=RBO+(R1*R2) W $J(R1*R2,0,2)
- +18 SET R2=$PIECE(RMPRI1,U,4)
- +19 SET RBO=RBO+(R1*R2)
- WRITE $JUSTIFY(R1*R2,0,2)
- +20 WRITE !?5,"TYPE: ",$SELECT($PIECE(RMPRI1,U,9)="X":"REPAIR",$PIECE(RMPRI1,U,9)="I":"INITIAL",$PIECE(RMPRI1,U,9)="R":"REPLACE",$PIECE(RMPRI1,U,9)="S":"SPARE",$PIECE(RMPRI1,U,9)="5":"RENTAL",1:"")
- +21 WRITE ?25,"CATEGORY: ",$SELECT($PIECE(RMPRI1,U,10)=1:"SC/OP",$PIECE(RMPRI1,U,10)=2:"SC/IP",$PIECE(RMPRI1,U,10)=3:"NSC/IP",$PIECE(RMPRI1,U,10)=4:"NSC/OP",1:"")
- +22 WRITE ?44,"SPECIAL CATEGORY: "
- +23 WRITE $SELECT($PIECE(RMPRI1,U,11)=1:"SPEC/LEG",$PIECE(RMPRI1,U,11)=2:"A&A",$PIECE(RMPRI1,U,11)=3:"PHC",$PIECE(RMPRI1,U,11)=4:"ELIGIBILITY REFORM",1:"")
- ASK IF $Y>17
- READ !!,"Enter '^' to Quit Display, <Return> to Continue : ",RMPRX:DTIME
- if '$TEST
- SET RMPRX="^"
- if RMPRX="^"
- QUIT
- +1 if $Y>17
- WRITE @IOF
- +2 QUIT
- EXIT KILL RMPRI1,R1,R2,ON,OFF
- QUIT