RMPR4LI ;PHX/HNB,RVD-DISPLAY ITEMS ON PURCHASE CARD TRANSACTION ;3/1/1996
;;3.0;PROSTHETICS;**3,12,19,20,28,30,41,90,182**;Feb 09, 1996;Build 13
;pass RMPRA
;
;RMPR*3.0*182 Add Contract, Model and Lot number to display
;
S:'$D(RMPRDELN) RMPRDELN="" S (RMPRI,RMPRCNT)=0,RMPRX="" D HOME^%ZIS W @IOF S:'$D(RMPRSER) RMPRSER=""
W !?5,$G(RMPRSSNE)
W ?55,"Purchase Card",!
W ?5,$$STA^RMPRUTIL,"-",$P(^RMPR(664,RMPRA,4),U,5)
I DUZ=$P(^RMPR(664,RMPRA,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W ?55,$$DEC($P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,0),U,9),RMPRA)
E W ?55,"encrypted"
W !
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(DCT) 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)
W !,?5,"BANK AUTHORIZATION: ",$P(^RMPR(664,RMPRA,4),U,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))
W !,?5,"VENDOR TRACKING: ",$P($G(^RMPR(664,RMPRA,1,RMPRI,4)),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),?31,$P(RMPRCPT,U,2)
K RCPT,RMPRCPT
W !,?5,"CPT MODIFIER: ",$P($G(^RMPR(664,RMPRA,1,RMPRI,4)),U,2)
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,"CONTRACT #: " S RMPRVAL=$S($P(^RMPR(664,RMPRA,1,RMPRI,0),U,14)]"":$P(^(0),U,14),$D(^RMPR(660,+$P(^(0),U,13),2)):$P(^(2),U,9),1:"") W RMPRVAL ;RMPR*3*182
W !?5,"MODEL: " S RMPRVAL=$S($P($G(^RMPR(664,RMPRA,1,RMPRI,2)),U,2)]"":$P(^(2),U,2),$D(^RMPR(660,+$P(^(0),U,13),9)):$P(^(9),U,2),1:"") W RMPRVAL
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 ;RMPR*3*182
W !?5,"LOT #: " S RMPRVAL=$S($P($G(^RMPR(664,RMPRA,1,RMPRI,2)),U,3)]"":$P(^(2),U,3),$D(^RMPR(660,+$P(^(0),U,13),0)):$P(^(0),U,24),1:"") W RMPRVAL ;RMPR*3*182
;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: "
K RMPRVAL
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
;
ENC(X,X1,X2) ;encrypt
;x is string to encrypt
;x1 duz
;x2 is ien to file 664
D EN^XUSHSHP Q X
DEC(X,X1,X2) ;decript
;x is encrypted string
;x1 is duz
;x2 is ien to file 664
D DE^XUSHSHP Q X
;end
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4LI 4181 printed Oct 16, 2024@18:33:28 Page 2
RMPR4LI ;PHX/HNB,RVD-DISPLAY ITEMS ON PURCHASE CARD TRANSACTION ;3/1/1996
+1 ;;3.0;PROSTHETICS;**3,12,19,20,28,30,41,90,182**;Feb 09, 1996;Build 13
+2 ;pass RMPRA
+3 ;
+4 ;RMPR*3.0*182 Add Contract, Model and Lot number to display
+5 ;
+6 if '$DATA(RMPRDELN)
SET RMPRDELN=""
SET (RMPRI,RMPRCNT)=0
SET RMPRX=""
DO HOME^%ZIS
WRITE @IOF
if '$DATA(RMPRSER)
SET RMPRSER=""
+7 WRITE !?5,$GET(RMPRSSNE)
+8 WRITE ?55,"Purchase Card",!
+9 WRITE ?5,$$STA^RMPRUTIL,"-",$PIECE(^RMPR(664,RMPRA,4),U,5)
+10 IF DUZ=$PIECE(^RMPR(664,RMPRA,0),U,9)!($DATA(^XUSEC("RMPR FCP MANAGER",DUZ)))
WRITE ?55,$$DEC($PIECE(^RMPR(664,RMPRA,4),U,1),$PIECE(^RMPR(664,RMPRA,0),U,9),RMPRA)
+11 IF '$TEST
WRITE ?55,"encrypted"
+12 WRITE !
+13 NEW RBO
SET RBO=0
+14 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(DCT)
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 WRITE !,?5,"BANK AUTHORIZATION: ",$PIECE(^RMPR(664,RMPRA,4),U,2)
+19 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 WRITE !,?5,"VENDOR TRACKING: ",$PIECE($GET(^RMPR(664,RMPRA,1,RMPRI,4)),U,1)
+6 SET RCPT=$PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,16)
+7 if RCPT
SET RMPRCPT=$GET(^RMPR(661.1,RCPT,0))
+8 IF $DATA(RMPRCPT)
WRITE !,?5,"PSAS HCPCS CODE: ",$PIECE(RMPRCPT,U,1),?31,$PIECE(RMPRCPT,U,2)
+9 KILL RCPT,RMPRCPT
+10 WRITE !,?5,"CPT MODIFIER: ",$PIECE($GET(^RMPR(664,RMPRA,1,RMPRI,4)),U,2)
+11 IF $PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,8)'=""
WRITE !?5,"REMARKS: ",$PIECE(^(0),U,8)
+12 IF $DATA(RMPRF)
IF RMPRF=2
WRITE !!?5,"DELIVER TO: ",RMPRDELN
+13 WRITE !!?5,"DESCRIPTION: ",$PIECE(RMPRI1,U,2)
+14 ;RMPR*3*182
WRITE !?5,"CONTRACT #: "
SET RMPRVAL=$SELECT($PIECE(^RMPR(664,RMPRA,1,RMPRI,0),U,14)]"":$PIECE(^(0),U,14),$DATA(^RMPR(660,+$PIECE(^(0),U,13),2)):$PIECE(^(2),U,9),1:"")
WRITE RMPRVAL
+15 WRITE !?5,"MODEL: "
SET RMPRVAL=$SELECT($PIECE($GET(^RMPR(664,RMPRA,1,RMPRI,2)),U,2)]"":$PIECE(^(2),U,2),$DATA(^RMPR(660,+$PIECE(^(0),U,13),9)):$PIECE(^(9),U,2),1:"")
WRITE RMPRVAL
+16 ;RMPR*3*182
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
+17 ;RMPR*3*182
WRITE !?5,"LOT #: "
SET RMPRVAL=$SELECT($PIECE($GET(^RMPR(664,RMPRA,1,RMPRI,2)),U,3)]"":$PIECE(^(2),U,3),$DATA(^RMPR(660,+$PIECE(^(0),U,13),0)):$PIECE(^(0),U,24),1:"")
WRITE RMPRVAL
+18 ;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: "
+19 KILL RMPRVAL
+20 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: "
+21 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: "
+22 ;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)
+23 SET R2=$PIECE(RMPRI1,U,4)
+24 SET RBO=RBO+(R1*R2)
WRITE $JUSTIFY(R1*R2,0,2)
+25 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:"")
+26 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:"")
+27 WRITE ?44,"SPECIAL CATEGORY: "
+28 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
+1 ;
ENC(X,X1,X2) ;encrypt
+1 ;x is string to encrypt
+2 ;x1 duz
+3 ;x2 is ien to file 664
+4 DO EN^XUSHSHP
QUIT X
DEC(X,X1,X2) ;decript
+1 ;x is encrypted string
+2 ;x1 is duz
+3 ;x2 is ien to file 664
+4 DO DE^XUSHSHP
QUIT X
+5 ;end
