RMPRN73 ;HINES/HNC -NPPD CALCULATIONS - CONT; 02/14/01
;;3.0;PROSTHETICS;**57,70,72,77**;Feb 09, 1996
;
;DBIA # 801 - for this routine, the agreement covers the field
; #.05 Short Description, file #441
;
;DBIA #10060 - Fileman read of file #200
;RVD patch 77 - defined the WHO variable.
CODE N I,NULINE
;
; read in NPPD new
F I=1:1 S NULINE=$P($T(DES+I^RMPRN72),";;",2) Q:$E(NULINE)="R" D
. S $P(^TMP($J,"N",STN,$P(NULINE,";",1)),U,15)=$P(NULINE,";",2)
. S ^TMP($J,"RMPRCODE",$P(NULINE,";",1))=$P(NULINE,";",2)
. Q
S $P(^TMP($J,"RMPRCODE"),U,1)=I-1 ;store number of new lines
;
; read in NPPD repair
F I=0:1 S NULINE=$P($T(REP+I^RMPRN72),";;",2) Q:$E(NULINE)'="R" D
. S $P(^TMP($J,"R",STN,$P(NULINE,";",1)),U,15)=$P(NULINE,";",2)
. S ^TMP($J,"RMPRCODE",$P(NULINE,";",1))=$P(NULINE,";",2)
. Q
S $P(^TMP($J,"RMPRCODE"),U,2)=I ;store number of repair lines
Q
HOLD ;hold screen
K DIR I IOST["C-" W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1
Q
HDR W @IOF S PAGE=PAGE+1
W !,LN,!,CODE
W ?10,^TMP($J,"RMPRCODE",CODE)
W ?35,DATE(3)," - ",DATE(4)
W ?70,"Page: ",PAGE
W !,LN,!
I IOM<119 W "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?62,"HCPCS DES",?76,"WHO",!,LN
I IOM>119 W "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?80,"HCPCS DES",?112,"WHO",?117,"#",!,LN
Q
DESP ;desplay detail records
S FL=""
S CODE=""
F S CODE=$O(^TMP($J,CODE)) Q:CODE="N" G:FL=1 EXIT D
.D HDR
.S RDX=0
.F S RDX=$O(^TMP($J,CODE,RDX)) D:RDX'>0 HOLD Q:RDX'>0 Q:FL=1 D
..S DFN=$P(^RMPR(660,RDX,0),U,2) Q:DFN=""
..D DEM^VADPT
..I $Y+6>IOSL,IOST["C-" K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1 Q:+Y'>0 D HDR
..I $Y+6>IOSL,IOST'["C-" D HDR
..W !,$E($P(VADM(1),",",1),1,9)
..W ?10,$P(VADM(2),"-",3)
..S TYPE=$P(^RMPR(660,RDX,0),U,4)
..S QTY=$P(^RMPR(660,RDX,0),U,7)
..S HCPCS=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,1)
..S HCPCSD=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,2)
..S WHO=$$GET1^DIQ(200,$P($G(^RMPR(660,RDX,0)),U,27),1)
..I $G(RDX) S OPEN=$P(^RMPR(660,RDX,0),U,12)
..I OPEN="" S OPEN="*"
..E S OPEN=" "
..S COST=^TMP($J,CODE,RDX)
..S SOURCE=$P(^RMPR(660,RDX,0),U,14)
..S DATE=$P(^RMPR(660,RDX,0),U,1),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
..S ITEM=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RDX,0),U,6),0),U,1),0),U,2)
..I IOM<119 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,11),?61,"|",?62,$E(HCPCSD,1,12),?76,WHO
..I IOM>118 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,29),?79,"|",?80,$E(HCPCSD,1,30),?112,WHO,?117,RDX
Q
DESPR ;repair dispaly
;
S CODE="R1"
F S CODE=$O(^TMP($J,CODE)) Q:CODE["RMPR" Q:FL=1 D
.D HDR
.S RDX=0
.F S RDX=$O(^TMP($J,CODE,RDX)) D:RDX'>0 HOLD Q:RDX'>0 Q:FL=1 D
..S DFN=$P(^RMPR(660,RDX,0),U,2) Q:DFN=""
..D DEM^VADPT
..Q:FL=1
..I $Y+6>IOSL,IOST["C-" K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1 Q:+Y'>0 D HDR
..I $Y+6>IOSL,IOST'["C-" D HDR
..W !,$E($P(VADM(1),",",1),1,9)
..W ?10,$P(VADM(2),"-",3)
..S TYPE=$P(^RMPR(660,RDX,0),U,4)
..S QTY=$P(^RMPR(660,RDX,0),U,7)
..S SOURCE=$P(^RMPR(660,RDX,0),U,14)
..I $P(^RMPR(660,RDX,0),U,17)'="" S HCPCS="#SHIP",ITEM="SHIPPING"
..I $P(^RMPR(660,RDX,0),U,26)'="" S HCPCS="#PICK",ITEM="PICKUP/DEL"
..S:$G(HCPCS)'["#" HCPCS=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,1)
..S:$G(HCPCS)'["#" HCPCSD=$P(^RMPR(661.1,$P(^RMPR(660,RDX,1),U,4),0),U,2)
..I $G(HCPCS)["#S" S HCPCSD="SHIPPING"
..I $G(HCPCS)["#P" S HCPCSD="PICKUP/DEL",SOURCE="C"
..I $G(RDX) S OPEN=$P(^RMPR(660,RDX,0),U,12)
..S WHO=$$GET1^DIQ(200,$P($G(^RMPR(660,RDX,0)),U,27),1)
..I OPEN="" S OPEN="*"
..E S OPEN=" "
..S COST=^TMP($J,CODE,RDX)
..;S SOURCE=$P(^RMPR(660,RDX,0),U,14)
..S DATE=$P(^RMPR(660,RDX,0),U,1),DATE=$E(DATE,4,5)_"/"_$E(DATE,6,7)
..S:$G(HCPCS)'["#" ITEM=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,RDX,0),U,6),0),U,1),0),U,2)
..I IOM<119 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,12),?62,$E(HCPCSD,1,12),?76,WHO
..I IOM>118 W ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$E(ITEM,1,29),?79,"|",?80,$E(HCPCSD,1,30),?112,WHO,?117,RDX
..K ITEM,HCPCSD,HCPCS
Q
EXIT ;
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRN73 4294 printed Sep 23, 2025@20:11:25 Page 2
RMPRN73 ;HINES/HNC -NPPD CALCULATIONS - CONT; 02/14/01
+1 ;;3.0;PROSTHETICS;**57,70,72,77**;Feb 09, 1996
+2 ;
+3 ;DBIA # 801 - for this routine, the agreement covers the field
+4 ; #.05 Short Description, file #441
+5 ;
+6 ;DBIA #10060 - Fileman read of file #200
+7 ;RVD patch 77 - defined the WHO variable.
CODE NEW I,NULINE
+1 ;
+2 ; read in NPPD new
+3 FOR I=1:1
SET NULINE=$PIECE($TEXT(DES+I^RMPRN72),";;",2)
if $EXTRACT(NULINE)="R"
QUIT
Begin DoDot:1
+4 SET $PIECE(^TMP($JOB,"N",STN,$PIECE(NULINE,";",1)),U,15)=$PIECE(NULINE,";",2)
+5 SET ^TMP($JOB,"RMPRCODE",$PIECE(NULINE,";",1))=$PIECE(NULINE,";",2)
+6 QUIT
End DoDot:1
+7 ;store number of new lines
SET $PIECE(^TMP($JOB,"RMPRCODE"),U,1)=I-1
+8 ;
+9 ; read in NPPD repair
+10 FOR I=0:1
SET NULINE=$PIECE($TEXT(REP+I^RMPRN72),";;",2)
if $EXTRACT(NULINE)'="R"
QUIT
Begin DoDot:1
+11 SET $PIECE(^TMP($JOB,"R",STN,$PIECE(NULINE,";",1)),U,15)=$PIECE(NULINE,";",2)
+12 SET ^TMP($JOB,"RMPRCODE",$PIECE(NULINE,";",1))=$PIECE(NULINE,";",2)
+13 QUIT
End DoDot:1
+14 ;store number of repair lines
SET $PIECE(^TMP($JOB,"RMPRCODE"),U,2)=I
+15 QUIT
HOLD ;hold screen
+1 KILL DIR
IF IOST["C-"
WRITE !!
SET DIR(0)="E"
DO ^DIR
if +Y'>0
SET FL=1
+2 QUIT
HDR WRITE @IOF
SET PAGE=PAGE+1
+1 WRITE !,LN,!,CODE
+2 WRITE ?10,^TMP($JOB,"RMPRCODE",CODE)
+3 WRITE ?35,DATE(3)," - ",DATE(4)
+4 WRITE ?70,"Page: ",PAGE
+5 WRITE !,LN,!
+6 IF IOM<119
WRITE "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?62,"HCPCS DES",?76,"WHO",!,LN
+7 IF IOM>119
WRITE "NAME",?10,"SSN",?16,"HCPCS",?22,"QTY",?27,"TYPE",?32,"COST",?42,"DATE",?48,"ITEM",?80,"HCPCS DES",?112,"WHO",?117,"#",!,LN
+8 QUIT
DESP ;desplay detail records
+1 SET FL=""
+2 SET CODE=""
+3 FOR
SET CODE=$ORDER(^TMP($JOB,CODE))
if CODE="N"
QUIT
if FL=1
GOTO EXIT
Begin DoDot:1
+4 DO HDR
+5 SET RDX=0
+6 FOR
SET RDX=$ORDER(^TMP($JOB,CODE,RDX))
if RDX'>0
DO HOLD
if RDX'>0
QUIT
if FL=1
QUIT
Begin DoDot:2
+7 SET DFN=$PIECE(^RMPR(660,RDX,0),U,2)
if DFN=""
QUIT
+8 DO DEM^VADPT
+9 IF $Y+6>IOSL
IF IOST["C-"
KILL DIR
WRITE !!
SET DIR(0)="E"
DO ^DIR
if +Y'>0
SET FL=1
if +Y'>0
QUIT
DO HDR
+10 IF $Y+6>IOSL
IF IOST'["C-"
DO HDR
+11 WRITE !,$EXTRACT($PIECE(VADM(1),",",1),1,9)
+12 WRITE ?10,$PIECE(VADM(2),"-",3)
+13 SET TYPE=$PIECE(^RMPR(660,RDX,0),U,4)
+14 SET QTY=$PIECE(^RMPR(660,RDX,0),U,7)
+15 SET HCPCS=$PIECE(^RMPR(661.1,$PIECE(^RMPR(660,RDX,1),U,4),0),U,1)
+16 SET HCPCSD=$PIECE(^RMPR(661.1,$PIECE(^RMPR(660,RDX,1),U,4),0),U,2)
+17 SET WHO=$$GET1^DIQ(200,$PIECE($GET(^RMPR(660,RDX,0)),U,27),1)
+18 IF $GET(RDX)
SET OPEN=$PIECE(^RMPR(660,RDX,0),U,12)
+19 IF OPEN=""
SET OPEN="*"
+20 IF '$TEST
SET OPEN=" "
+21 SET COST=^TMP($JOB,CODE,RDX)
+22 SET SOURCE=$PIECE(^RMPR(660,RDX,0),U,14)
+23 SET DATE=$PIECE(^RMPR(660,RDX,0),U,1)
SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)
+24 SET ITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,RDX,0),U,6),0),U,1),0),U,2)
+25 IF IOM<119
WRITE ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$EXTRACT(ITEM,1,11),?61,"|",?62,$EXTRACT(HCPCSD,1,12),?76,WHO
+26 IF IOM>118
WRITE ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$EXTRACT(ITEM,1,29),?79,"|",?80,$EXTRACT(HCPCSD,1,30),?112,WHO,?117,RDX
End DoDot:2
End DoDot:1
+27 QUIT
DESPR ;repair dispaly
+1 ;
+2 SET CODE="R1"
+3 FOR
SET CODE=$ORDER(^TMP($JOB,CODE))
if CODE["RMPR"
QUIT
if FL=1
QUIT
Begin DoDot:1
+4 DO HDR
+5 SET RDX=0
+6 FOR
SET RDX=$ORDER(^TMP($JOB,CODE,RDX))
if RDX'>0
DO HOLD
if RDX'>0
QUIT
if FL=1
QUIT
Begin DoDot:2
+7 SET DFN=$PIECE(^RMPR(660,RDX,0),U,2)
if DFN=""
QUIT
+8 DO DEM^VADPT
+9 if FL=1
QUIT
+10 IF $Y+6>IOSL
IF IOST["C-"
KILL DIR
WRITE !!
SET DIR(0)="E"
DO ^DIR
if +Y'>0
SET FL=1
if +Y'>0
QUIT
DO HDR
+11 IF $Y+6>IOSL
IF IOST'["C-"
DO HDR
+12 WRITE !,$EXTRACT($PIECE(VADM(1),",",1),1,9)
+13 WRITE ?10,$PIECE(VADM(2),"-",3)
+14 SET TYPE=$PIECE(^RMPR(660,RDX,0),U,4)
+15 SET QTY=$PIECE(^RMPR(660,RDX,0),U,7)
+16 SET SOURCE=$PIECE(^RMPR(660,RDX,0),U,14)
+17 IF $PIECE(^RMPR(660,RDX,0),U,17)'=""
SET HCPCS="#SHIP"
SET ITEM="SHIPPING"
+18 IF $PIECE(^RMPR(660,RDX,0),U,26)'=""
SET HCPCS="#PICK"
SET ITEM="PICKUP/DEL"
+19 if $GET(HCPCS)'["#"
SET HCPCS=$PIECE(^RMPR(661.1,$PIECE(^RMPR(660,RDX,1),U,4),0),U,1)
+20 if $GET(HCPCS)'["#"
SET HCPCSD=$PIECE(^RMPR(661.1,$PIECE(^RMPR(660,RDX,1),U,4),0),U,2)
+21 IF $GET(HCPCS)["#S"
SET HCPCSD="SHIPPING"
+22 IF $GET(HCPCS)["#P"
SET HCPCSD="PICKUP/DEL"
SET SOURCE="C"
+23 IF $GET(RDX)
SET OPEN=$PIECE(^RMPR(660,RDX,0),U,12)
+24 SET WHO=$$GET1^DIQ(200,$PIECE($GET(^RMPR(660,RDX,0)),U,27),1)
+25 IF OPEN=""
SET OPEN="*"
+26 IF '$TEST
SET OPEN=" "
+27 SET COST=^TMP($JOB,CODE,RDX)
+28 ;S SOURCE=$P(^RMPR(660,RDX,0),U,14)
+29 SET DATE=$PIECE(^RMPR(660,RDX,0),U,1)
SET DATE=$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)
+30 if $GET(HCPCS)'["#"
SET ITEM=$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,RDX,0),U,6),0),U,1),0),U,2)
+31 IF IOM<119
WRITE ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$EXTRACT(ITEM,1,12),?62,$EXTRACT(HCPCSD,1,12),?76,WHO
+32 IF IOM>118
WRITE ?16,HCPCS,?22,QTY,?27,TYPE,?29,SOURCE,?32,OPEN,COST,?42,DATE,?48,$EXTRACT(ITEM,1,29),?79,"|",?80,$EXTRACT(HCPCSD,1,30),?112,WHO,?117,RDX
+33 KILL ITEM,HCPCSD,HCPCS
End DoDot:2
End DoDot:1
+34 QUIT
EXIT ;
+1 QUIT
+2 ;END
