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