RMPRN7UT ;HINES-CIOFO/HNC - DISPLAY HEADER GROUPS NPPD;2-14-01
;;3.0;PROSTHETICS;**57,84,103,144**;Feb 09, 1996;Build 17
;
; AAC Patch 84, 2/25/04, additions, deletions and change descriptions for Groups and lines
; AAC Patch 84, 2/25/04, change description for line 6
; AAC Patch 103, 1/17/05 - NPPD CATEGORIES/LINES - NEW and REPAIR UPDATES
;
DIS W !,?5,"1. 2529-3 WHEELCHAIRS AND ACCESSORIES"
W !,?5,"2. 2529-3 ARTIFICIAL LEGS"
W !,?5,"3. 2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"
W !,?5,"4. 2529-3 ORTHOSIS/ORTHOTICS"
W !,?5,"5. 2529-3 SHOES/ORTHOTICS"
W !,?5,"6. 2529-3 SENSORI-NEURO AIDS"
W !,?5,"7. 2529-3 RESTORATIONS"
W !,?5,"8. 2529-3 OXYGEN AND RESPIRATORY"
W !,?5,"9. 2529-3 MEDICAL EQUIPMENT"
W !,?5,"10. 2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"
W !,?5,"11. 2529-3 HOME DIALYSIS PROGRAM"
W !,?5,"12. 2529-3 ADAPTIVE EQUIPMENT"
W !,?5,"13. 2529-3 HISA"
W !,?5,"14. 2529-3 SURGICAL IMPLANTS"
W !,?5,"15. 2529-3 MISC"
W !,?5,"16. 2529-3 REPAIR"
W !,?5,"17. 2529-3 BIOLOGICAL IMPLANTS"
ASK ;
K DIR,DTOUT,DIRUT
S RMPRCDE=""
S DIR(0)="N^1:17:0"
S DIR("A")="Select 2529-3 NPPD Group "
D ^DIR
G:$D(DIRUT)!($D(DTOUT)) EXIT
S BR=0,BRC=0 K BRA W @IOF
I Y=1 S SELY=10
I Y=2 S SELY=20
I Y=3 S SELY=30
I Y=4 S SELY=40
I Y=5 S SELY=50
I Y=6 S SELY=60
I Y=7 S SELY=70
I Y=8 S SELY=80
I Y=9 S SELY=90
I Y=10 S SELY=91
I Y=11 S SELY=92
I Y=12 S SELY=93
I Y=13 S SELY=94
I Y=14 S SELY=96
I Y=15 S SELY=99
I Y=16 S SELY=100
I Y=17 S SELY=97
F S BR=$O(^TMP($J,"RMPRCODE",BR)) Q:BR="" D
.I $E(BR,1,2)=SELY S BRC=BRC+1 W !?5,BRC_".",?10,BR,?18,^(BR) S BRA(BRC,BR)=""
.Q
I SELY=100 D
. D RSEL
. Q
E D
. D NSEL
. Q
G:$D(DIRUT)!($D(DTOUT)) EXIT
Q
RSEL ;repair selection
N CNT,Y,OFFS,TXT,I
S CNT=$P(^TMP($J,"RMPRCODE"),U,2) ; num of NPPD repair lines
S OFFS=CNT-(CNT\2)-1
F I=0:1:OFFS D
. S TXT=$P($T(REP+I^RMPRN72),";;",2)
. W !,$J(I+1,2)_".",?5,$P(TXT,";",1),?14,$P(TXT,";",2)
. S TXT=$P($T(REP+I+OFFS+1^RMPRN72),";;",2)
. Q:$E(TXT)'="R"
. W ?35,$J(I+2+OFFS,2)_".",?40,$P(TXT,";",1),?51,$P(TXT,";",2)
. Q
F I=OFFS:1:17 W !
S DIR(0)="N^1:"_CNT_":0"
S DIR("A")="Select 2529-3 NPPD Line "
D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S TXT=$P($T(REP+Y-1^RMPRN72),";;",2)
S RMPRCDE=$P(TXT,";",1)
Q
NSEL ;new select
I BR'="" W "QUIT" Q
W !
S DIR(0)="N^1:"_BRC_":0"
S DIR("A")="Select 2529-3 NPPD Line "
D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S RMPRCDE=$O(BRA(Y,RMPRCDE))
Q
EXIT ;exit on ^ or timeout
K ^TMP($J)
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRN7UT 2589 printed Sep 23, 2025@20:11:30 Page 2
RMPRN7UT ;HINES-CIOFO/HNC - DISPLAY HEADER GROUPS NPPD;2-14-01
+1 ;;3.0;PROSTHETICS;**57,84,103,144**;Feb 09, 1996;Build 17
+2 ;
+3 ; AAC Patch 84, 2/25/04, additions, deletions and change descriptions for Groups and lines
+4 ; AAC Patch 84, 2/25/04, change description for line 6
+5 ; AAC Patch 103, 1/17/05 - NPPD CATEGORIES/LINES - NEW and REPAIR UPDATES
+6 ;
DIS WRITE !,?5,"1. 2529-3 WHEELCHAIRS AND ACCESSORIES"
+1 WRITE !,?5,"2. 2529-3 ARTIFICIAL LEGS"
+2 WRITE !,?5,"3. 2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"
+3 WRITE !,?5,"4. 2529-3 ORTHOSIS/ORTHOTICS"
+4 WRITE !,?5,"5. 2529-3 SHOES/ORTHOTICS"
+5 WRITE !,?5,"6. 2529-3 SENSORI-NEURO AIDS"
+6 WRITE !,?5,"7. 2529-3 RESTORATIONS"
+7 WRITE !,?5,"8. 2529-3 OXYGEN AND RESPIRATORY"
+8 WRITE !,?5,"9. 2529-3 MEDICAL EQUIPMENT"
+9 WRITE !,?5,"10. 2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"
+10 WRITE !,?5,"11. 2529-3 HOME DIALYSIS PROGRAM"
+11 WRITE !,?5,"12. 2529-3 ADAPTIVE EQUIPMENT"
+12 WRITE !,?5,"13. 2529-3 HISA"
+13 WRITE !,?5,"14. 2529-3 SURGICAL IMPLANTS"
+14 WRITE !,?5,"15. 2529-3 MISC"
+15 WRITE !,?5,"16. 2529-3 REPAIR"
+16 WRITE !,?5,"17. 2529-3 BIOLOGICAL IMPLANTS"
ASK ;
+1 KILL DIR,DTOUT,DIRUT
+2 SET RMPRCDE=""
+3 SET DIR(0)="N^1:17:0"
+4 SET DIR("A")="Select 2529-3 NPPD Group "
+5 DO ^DIR
+6 if $DATA(DIRUT)!($DATA(DTOUT))
GOTO EXIT
+7 SET BR=0
SET BRC=0
KILL BRA
WRITE @IOF
+8 IF Y=1
SET SELY=10
+9 IF Y=2
SET SELY=20
+10 IF Y=3
SET SELY=30
+11 IF Y=4
SET SELY=40
+12 IF Y=5
SET SELY=50
+13 IF Y=6
SET SELY=60
+14 IF Y=7
SET SELY=70
+15 IF Y=8
SET SELY=80
+16 IF Y=9
SET SELY=90
+17 IF Y=10
SET SELY=91
+18 IF Y=11
SET SELY=92
+19 IF Y=12
SET SELY=93
+20 IF Y=13
SET SELY=94
+21 IF Y=14
SET SELY=96
+22 IF Y=15
SET SELY=99
+23 IF Y=16
SET SELY=100
+24 IF Y=17
SET SELY=97
+25 FOR
SET BR=$ORDER(^TMP($JOB,"RMPRCODE",BR))
if BR=""
QUIT
Begin DoDot:1
+26 IF $EXTRACT(BR,1,2)=SELY
SET BRC=BRC+1
WRITE !?5,BRC_".",?10,BR,?18,^(BR)
SET BRA(BRC,BR)=""
+27 QUIT
End DoDot:1
+28 IF SELY=100
Begin DoDot:1
+29 DO RSEL
+30 QUIT
End DoDot:1
+31 IF '$TEST
Begin DoDot:1
+32 DO NSEL
+33 QUIT
End DoDot:1
+34 if $DATA(DIRUT)!($DATA(DTOUT))
GOTO EXIT
+35 QUIT
RSEL ;repair selection
+1 NEW CNT,Y,OFFS,TXT,I
+2 ; num of NPPD repair lines
SET CNT=$PIECE(^TMP($JOB,"RMPRCODE"),U,2)
+3 SET OFFS=CNT-(CNT\2)-1
+4 FOR I=0:1:OFFS
Begin DoDot:1
+5 SET TXT=$PIECE($TEXT(REP+I^RMPRN72),";;",2)
+6 WRITE !,$JUSTIFY(I+1,2)_".",?5,$PIECE(TXT,";",1),?14,$PIECE(TXT,";",2)
+7 SET TXT=$PIECE($TEXT(REP+I+OFFS+1^RMPRN72),";;",2)
+8 if $EXTRACT(TXT)'="R"
QUIT
+9 WRITE ?35,$JUSTIFY(I+2+OFFS,2)_".",?40,$PIECE(TXT,";",1),?51,$PIECE(TXT,";",2)
+10 QUIT
End DoDot:1
+11 FOR I=OFFS:1:17
WRITE !
+12 SET DIR(0)="N^1:"_CNT_":0"
+13 SET DIR("A")="Select 2529-3 NPPD Line "
+14 DO ^DIR
+15 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+16 SET TXT=$PIECE($TEXT(REP+Y-1^RMPRN72),";;",2)
+17 SET RMPRCDE=$PIECE(TXT,";",1)
+18 QUIT
NSEL ;new select
+1 IF BR'=""
WRITE "QUIT"
QUIT
+2 WRITE !
+3 SET DIR(0)="N^1:"_BRC_":0"
+4 SET DIR("A")="Select 2529-3 NPPD Line "
+5 DO ^DIR
+6 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+7 SET RMPRCDE=$ORDER(BRA(Y,RMPRCDE))
+8 QUIT
EXIT ;exit on ^ or timeout
+1 KILL ^TMP($JOB)
+2 QUIT
+3 ;END
