RMPRPAT7 ;HINES-CIOFO/HNC DISPLAY NPPD KEY ITEMS CONSOLIDATED
;;3.0;PROSTHETICS;**32,34,35,77,162**;Feb 14, 1998;Build 5
;;
;RVD 3/18/03 patch #77 - only prints item for the same pt.
N HCHCPS,HCHCPSD
W !,?5,"PSAS HCPCS",?18,"DESCRIPTION",?48,"QTY",?52,"COST",?62,"ITEM"
W !,RMPR("L") S HCTOT=0
S HCREC=$P(IT(AN),U,1) Q:HCREC'>0
S HC=$G(R19(660,HCREC,68,"E")) Q:HC=""
S HC1=0
F S HC1=$O(^TMP($J,"TTT",HC,HCREC,HC1)) Q:HC1'>0 D
.Q:$P($G(^RMPR(660,HC1,0)),U,10)'=RMPR("STA") ;QUIT if different station;RMPR*3.0*162
.S (HCHCPS,HCHCPSD)=""
.I $P(^RMPR(660,HC1,0),U,2)'=RMPRDFN Q
.S HCQTY=$P(^RMPR(660,HC1,0),U,7)
.S HCCOST=$P(^RMPR(660,HC1,0),U,16)
.S HCTOT=HCTOT+HCCOST
.S HCRK=$P(^RMPR(660,HC1,0),U,6)
.I HCRK S HCRK=$P(^RMPR(661,HCRK,0),U,1),HCRK=$P(^PRC(441,HCRK,0),U,2)
.S HCHCP=$P($G(^RMPR(660,HC1,1)),U,4)
.I HCHCP S HCHCPS=$P(^RMPR(661.1,HCHCP,0),U,1),HCHCPSD=$P(^(0),U,2)
.I $P(^RMPR(660,HC1,0),U,17) S HCHCPSD="SHIPPING" ;modify descrip to shipping charge;RMPR*3.0*162
.W !,?5,$G(HCHCPS),?18,$G(HCHCPSD)
.W ?48,HCQTY
.W ?52,"$"_$J($FN(HCCOST,"P",2),9)
.W ?62,$E(HCRK,1,18)
W !,?52,"========="
W !,?52,"$"_$J($FN(HCTOT,"P",2),9)
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPAT7 1199 printed Sep 23, 2025@20:11:51 Page 2
RMPRPAT7 ;HINES-CIOFO/HNC DISPLAY NPPD KEY ITEMS CONSOLIDATED
+1 ;;3.0;PROSTHETICS;**32,34,35,77,162**;Feb 14, 1998;Build 5
+2 ;;
+3 ;RVD 3/18/03 patch #77 - only prints item for the same pt.
+4 NEW HCHCPS,HCHCPSD
+5 WRITE !,?5,"PSAS HCPCS",?18,"DESCRIPTION",?48,"QTY",?52,"COST",?62,"ITEM"
+6 WRITE !,RMPR("L")
SET HCTOT=0
+7 SET HCREC=$PIECE(IT(AN),U,1)
if HCREC'>0
QUIT
+8 SET HC=$GET(R19(660,HCREC,68,"E"))
if HC=""
QUIT
+9 SET HC1=0
+10 FOR
SET HC1=$ORDER(^TMP($JOB,"TTT",HC,HCREC,HC1))
if HC1'>0
QUIT
Begin DoDot:1
+11 ;QUIT if different station;RMPR*3.0*162
if $PIECE($GET(^RMPR(660,HC1,0)),U,10)'=RMPR("STA")
QUIT
+12 SET (HCHCPS,HCHCPSD)=""
+13 IF $PIECE(^RMPR(660,HC1,0),U,2)'=RMPRDFN
QUIT
+14 SET HCQTY=$PIECE(^RMPR(660,HC1,0),U,7)
+15 SET HCCOST=$PIECE(^RMPR(660,HC1,0),U,16)
+16 SET HCTOT=HCTOT+HCCOST
+17 SET HCRK=$PIECE(^RMPR(660,HC1,0),U,6)
+18 IF HCRK
SET HCRK=$PIECE(^RMPR(661,HCRK,0),U,1)
SET HCRK=$PIECE(^PRC(441,HCRK,0),U,2)
+19 SET HCHCP=$PIECE($GET(^RMPR(660,HC1,1)),U,4)
+20 IF HCHCP
SET HCHCPS=$PIECE(^RMPR(661.1,HCHCP,0),U,1)
SET HCHCPSD=$PIECE(^(0),U,2)
+21 ;modify descrip to shipping charge;RMPR*3.0*162
IF $PIECE(^RMPR(660,HC1,0),U,17)
SET HCHCPSD="SHIPPING"
+22 WRITE !,?5,$GET(HCHCPS),?18,$GET(HCHCPSD)
+23 WRITE ?48,HCQTY
+24 WRITE ?52,"$"_$JUSTIFY($FNUMBER(HCCOST,"P",2),9)
+25 WRITE ?62,$EXTRACT(HCRK,1,18)
End DoDot:1
+26 WRITE !,?52,"========="
+27 WRITE !,?52,"$"_$JUSTIFY($FNUMBER(HCTOT,"P",2),9)
+28 ;END
