- 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 Feb 19, 2025@00:01:43 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
