RMPRN7PT.m

RMPRN7PT ;HINES/HNC -PRINT NPPD NEW WORKSHEETS ;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 group 600

 ; AAC Patch 103, 1/17/05 NPPD CATEGORIES/LINES - NEW and REPAIRS

 ;

 K ^TMP($J,"NS")

 S STN=1

 S SSNCT=0,BDC=0

 F  S BDC=$O(^TMP($J,"A",BDC)) Q:BDC'>0  S SSNCT=SSNCT+1

 K BDC,^TMP($J,"A")

 F  S STN=$O(^TMP($J,"N",STN)) Q:STN=""  W:$E(IOST,1,2)="C-" @IOF D HDR,CDATA,SUM

 Q

HDR ;

 W !,"REPORT OF 2529-3 NEW PROSTHETICS ACTIVITIES"

 ;header based on sort select

 W !,$$HDR^RMPRN7S(RMPRDET)

 S Y=DATE(1) D DD^%DT S DATE(3)=Y W !,DATE(3)," - " S Y=DATE(2) D DD^%DT S DATE(4)=Y W DATE(4)

 W !,?10,"STATION: ",STN

 ;RMPRSUM if summary header

 Q:$G(RMPRSUM)

 W !!

 W !,"Line",?7,"Item",?21,"VA",?26,"Com",?31,"Total",?37,"Cost",?46

 W "Ave Com",?54

 W "SC/OP",?61,"NSC/OP",?68,"SC/IP",?74,"NSC/IP"

 I IOM>120 D

 .W ?83,"SP LEG"

 .W ?90,"A&A",?97,"PHC",?104,"ELG REF",?112,"NEW",?120,"$ELG REF"

 Q

CDATA ;

 S LINE="",LINEP=""

 S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

 F  S LINE=$O(^TMP($J,"N",STN,LINE)) Q:LINE=""  Q:FL=1  D

 .I $E(LINE,0,3)'=$E(LINEP,0,3) D SUM Q:FL=1  D LBL

 .W !,LINE,?7,$E($P(^TMP($J,"N",STN,LINE),U,15),1,14)

 .W ?21,$P(^TMP($J,"N",STN,LINE),U,1) S CA=CA+$P(^(LINE),U,1)

 .W ?26,$P(^TMP($J,"N",STN,LINE),U,2) S CB=CB+$P(^(LINE),U,2)

 .W ?31,$P(^TMP($J,"N",STN,LINE),U,1)+($P(^TMP($J,"N",STN,LINE),U,2))

 .W ?37,$FN($J($P(^TMP($J,"N",STN,LINE),U,3),0,0),",") S CC=CC+$P(^(LINE),U,3)

 .W:$P(^TMP($J,"N",STN,LINE),U,2)>0 ?46,$FN($J(($P(^(LINE),U,3))/($P(^(LINE),U,2)),0,0),",")

 .W ?55,$P(^TMP($J,"N",STN,LINE),U,4) S CD=CD+$P(^(LINE),U,4)

 .W ?62,$P(^TMP($J,"N",STN,LINE),U,5) S CE=CE+$P(^(LINE),U,5)

 .W ?69,$P(^TMP($J,"N",STN,LINE),U,6) S CF=CF+$P(^(LINE),U,6)

 .W ?76,$P(^TMP($J,"N",STN,LINE),U,7) S CG=CG+$P(^(LINE),U,7)

 .S CH=CH+$P(^TMP($J,"N",STN,LINE),U,8)

 .S CI=CI+$P(^TMP($J,"N",STN,LINE),U,9)

 .S CJ=CJ+$P(^TMP($J,"N",STN,LINE),U,10)

 .S CK=CK+$P(^TMP($J,"N",STN,LINE),U,11)

 .S CL=CL+$P(^TMP($J,"N",STN,LINE),U,12)

 .S CM=CM+$P(^TMP($J,"N",STN,LINE),U,16)

 .I IOM>120 D

 ..W ?83,$P(^TMP($J,"N",STN,LINE),U,8)

 ..W ?90,$P(^TMP($J,"N",STN,LINE),U,9)

 ..W ?97,$P(^TMP($J,"N",STN,LINE),U,10)

 ..W ?104,$P(^TMP($J,"N",STN,LINE),U,11)

 ..W ?112,$P(^TMP($J,"N",STN,LINE),U,12)

 ..W ?120,$P(^TMP($J,"N",STN,LINE),U,16)

 .S LINEP=LINE

 Q

SUM ;Print summary for group

 Q:FL=1

 I LINEP'="" D  Q:FL=1

 .I $Y+13>IOSL,IOST["C-" D CHK Q:FL=1

 .S GROUPT=CA_U_CB_U_(CA+CB)_U_$J(CC,0,0)_U_CD_U_CE_U_CF_U_CG_U_CH_U_CI_U_CJ_U_CK_U_CL_U_CM

 .W !,LN,!

 .W ?21,CA,?26,CB,?31,(CA+CB),?37,$FN($J(CC,0,0),","),?55,CD,?62,CE,?69,CF,?76,CG

 .I IOM>120 W ?83,CH,?90,CI,?97,CJ,?104,CK,?112,CL,?120,CM

 .W !

 .D LBLG

 .S ^TMP($J,"NS",STN,GROUP,STN)=GROUPT

 .S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

 Q:$G(LINEP)'="999 ZL"

 D FSUM S RMPRSUM=1 D HDR K RMPRSUM

 W !!,"STATION SUMMARY (2529-3 NEW ACTIVITIES)"

 W !,?21,"VA",?31,"Com",?41,"Total",?51,"Cost",?61

 W "Ave Com",?71,"Elg Ref $"

 W !,LN

 W !,?21,$FN(CA,","),?31,$FN(CB,","),?41,$FN((CA+CB),","),?51,"$"_$FN($J(CC,0,0),",")

 I CB>0 W ?61,"$"_$FN($J((CC/CB),0,0),",")

 I CM>0 W ?71,"$"_$FN($J(CM,0,0),",")

 W !,LN,!!

 W ?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"

 W !,LN,!,?21,CD,?31,CE,?41,CF,?51,CG

 W !,LN

 W !,?21,"SPEC LEG",?31,"A&A",?41,"PHC",?51,"ELG REF",?61,"NEW"

 W !,LN,!,?21,CH,?31,CI,?41,CJ,?51,CK,?61,CL,!,LN

 W !,?21,"Total Disability: ",$FN((CD+CE+CF+CG),","),?47,"Unique SSN: ",SSNCT,!

 S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

 I IOST["C-" D CHK

 Q

LBLG ;group description for final summary

 I $E(LINEP,0,3)=100 S GROUP=$E(LINEP,0,3)_" 2529-3 WHEELCHAIRS AND ACCESSORIES"

 I $E(LINEP,0,3)=200 S GROUP=$E(LINEP,0,3)_" 2529-3 ARTIFICIAL LEGS"

 I $E(LINEP,0,3)=300 S GROUP=$E(LINEP,0,3)_" 2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"

 I $E(LINEP,0,3)=400 S GROUP=$E(LINEP,0,3)_" 2529-3 ORTHOSIS/ORTHOTICS"

 I $E(LINEP,0,3)=500 S GROUP=$E(LINEP,0,3)_" 2529-3 SHOES/ORTHOTICS"

 I $E(LINEP,0,3)=600 S GROUP=$E(LINEP,0,3)_" 2529-3 SENSORI-NEURO AIDS"

 I $E(LINEP,0,3)=700 S GROUP=$E(LINEP,0,3)_" 2529-3 RESTORATIONS"

 I $E(LINEP,0,3)=800 S GROUP=$E(LINEP,0,3)_" 2529-3 OXYGEN AND RESPIRATORY"

 I $E(LINEP,0,3)=900 S GROUP=$E(LINEP,0,3)_" 2529-3 MEDICAL EQUIPMENT"

 I $E(LINEP,0,3)=910 S GROUP=$E(LINEP,0,3)_" 2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"

 I $E(LINEP,0,3)=920 S GROUP=$E(LINEP,0,3)_" 2529-3 HOME DIALYSIS PROGRAM"

 I $E(LINEP,0,3)=930 S GROUP=$E(LINEP,0,3)_" 2529-3 ADAPTIVE EQUIPMENT"

 I $E(LINEP,0,3)=940 S GROUP=$E(LINEP,0,3)_" 2529-3 HISA"

 I $E(LINEP,0,3)=960 S GROUP=$E(LINEP,0,3)_" 2529-3 SURGICAL IMPLANTS"

 I $E(LINEP,0,3)=970 S GROUP=$E(LINEP,0,3)_" 2529-3 BIOLOGICAL IMPLANTS"

 I $E(LINEP,0,3)=999 S GROUP=$E(LINEP,0,3)_" 2529-3 MISC"

 Q

LBL ;label for group

 I $E(LINE,0,3)=100 W !,"2529-3 WHEELCHAIRS AND ACCESSORIES"

 I $E(LINE,0,3)=200 W !,"2529-3 ARTIFICIAL LEGS"

 I $E(LINE,0,3)=300 W !,"2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"

 I $E(LINE,0,3)=400 W !,"2529-3 ORTHOSIS/ORTHOTICS"

 I $E(LINE,0,3)=500,IOST'["C-" W @IOF D HDR W !,"2529-3 SHOES/ORTHOTICS"

 I $E(LINE,0,3)=500,IOST["C-" W !,"2529-3 SHOES/ORTHOTICS"

 I $E(LINE,0,3)=600 W !,"2529-3 SENSORI-NEURO AIDS"

 I $E(LINE,0,3)=700 W !,"2529-3 RESTORATIONS"

 I $E(LINE,0,3)=800 W !,"2529-3 OXYGEN AND RESPIRATORY"

 I $E(LINE,0,3)=900,IOST'["C-" W @IOF D HDR W !,"2529-3 MEDICAL EQUIPMENT"

 I $E(LINE,0,3)=900,IOST["C-" W !,"2529-3 MEDICAL EQUIPMENT"

 I $E(LINE,0,3)=910 W !,"2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"

 I $E(LINE,0,3)=920 W !,"2529-3 HOME DIALYSIS PROGRAM"

 I $E(LINE,0,3)=930 W !,"2529-3 ADAPTIVE EQUIPMENT"

 I $E(LINE,0,3)=940 W !,"2529-3 HISA"

 I $E(LINE,0,3)=960 W !,"2529-3 SURGICAL IMPLANTS"

 I $E(LINE,0,3)=970 W !,"2529-3 BIOLOGICAL IMPLANTS"

 I $E(LINE,0,3)=999,IOST'["C-" W @IOF D HDR W !,"2529-3 MISC"

 I $E(LINE,0,3)=999,IOST["C-" W !,"2529-3 MISC"

 Q

FSUM ;final summay on New Worksheets STATION

 S H=0

 F  S H=$O(^TMP($J,"NS",STN,H)) Q:H=""  D

 .S H1=0,H2=0

 .F  S H1=$O(^TMP($J,"NS",STN,H,H1)) Q:H1=""  D

 ..Q:H1'=STN

 ..S H2=^TMP($J,"NS",STN,H,H1)

 ..S CA=CA+$P(H2,U,1)

 ..S CB=CB+$P(H2,U,2)

 ..S CC=CC+$P(H2,U,4)

 ..S CD=CD+$P(H2,U,5)

 ..S CE=CE+$P(H2,U,6)

 ..S CF=CF+$P(H2,U,7)

 ..S CG=CG+$P(H2,U,8)

 ..S CH=CH+$P(H2,U,9)

 ..S CI=CI+$P(H2,U,10)

 ..S CJ=CJ+$P(H2,U,11)

 ..S CK=CK+$P(H2,U,12)

 ..S CL=CL+$P(H2,U,13)

 ..S CM=CM+$P(H2,U,14)

 Q

CHK ;

 K DIR W !! S DIR(0)="E" D ^DIR S:+Y'>0 FL=1

 W @IOF

 Q

 ;END

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPRN7PT   6629     printed  Feb 19, 2025@00:01:46                                                                                                                                                                                                    Page 2

RMPRN7PT  ;HINES/HNC -PRINT NPPD NEW WORKSHEETS ;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 group 600

 +5       ; AAC Patch 103, 1/17/05 NPPD CATEGORIES/LINES - NEW and REPAIRS

 +6       ;

 +7        KILL ^TMP($JOB,"NS")

 +8        SET STN=1

 +9        SET SSNCT=0

           SET BDC=0

 +10       FOR 

               SET BDC=$ORDER(^TMP($JOB,"A",BDC))

               if BDC'>0

                   QUIT 

               SET SSNCT=SSNCT+1

 +11       KILL BDC,^TMP($JOB,"A")

 +12       FOR 

               SET STN=$ORDER(^TMP($JOB,"N",STN))

               if STN=""

                   QUIT 

               if $EXTRACT(IOST,1,2)="C-"

                   WRITE @IOF

               DO HDR

               DO CDATA

               DO SUM

 +13       QUIT 

HDR       ;

 +1        WRITE !,"REPORT OF 2529-3 NEW PROSTHETICS ACTIVITIES"

 +2       ;header based on sort select

 +3        WRITE !,$$HDR^RMPRN7S(RMPRDET)

 +4        SET Y=DATE(1)

           DO DD^%DT

           SET DATE(3)=Y

           WRITE !,DATE(3)," - "

           SET Y=DATE(2)

           DO DD^%DT

           SET DATE(4)=Y

           WRITE DATE(4)

 +5        WRITE !,?10,"STATION: ",STN

 +6       ;RMPRSUM if summary header

 +7        if $GET(RMPRSUM)

               QUIT 

 +8        WRITE !!

 +9        WRITE !,"Line",?7,"Item",?21,"VA",?26,"Com",?31,"Total",?37,"Cost",?46

 +10       WRITE "Ave Com",?54

 +11       WRITE "SC/OP",?61,"NSC/OP",?68,"SC/IP",?74,"NSC/IP"

 +12       IF IOM>120

               Begin DoDot:1

 +13               WRITE ?83,"SP LEG"

 +14               WRITE ?90,"A&A",?97,"PHC",?104,"ELG REF",?112,"NEW",?120,"$ELG REF"

               End DoDot:1

 +15       QUIT 

CDATA     ;

 +1        SET LINE=""

           SET LINEP=""

 +2        SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

 +3        FOR 

               SET LINE=$ORDER(^TMP($JOB,"N",STN,LINE))

               if LINE=""

                   QUIT 

               if FL=1

                   QUIT 

               Begin DoDot:1

 +4                IF $EXTRACT(LINE,0,3)'=$EXTRACT(LINEP,0,3)

                       DO SUM

                       if FL=1

                           QUIT 

                       DO LBL

 +5                WRITE !,LINE,?7,$EXTRACT($PIECE(^TMP($JOB,"N",STN,LINE),U,15),1,14)

 +6                WRITE ?21,$PIECE(^TMP($JOB,"N",STN,LINE),U,1)

                   SET CA=CA+$PIECE(^(LINE),U,1)

 +7                WRITE ?26,$PIECE(^TMP($JOB,"N",STN,LINE),U,2)

                   SET CB=CB+$PIECE(^(LINE),U,2)

 +8                WRITE ?31,$PIECE(^TMP($JOB,"N",STN,LINE),U,1)+($PIECE(^TMP($JOB,"N",STN,LINE),U,2))

 +9                WRITE ?37,$FNUMBER($JUSTIFY($PIECE(^TMP($JOB,"N",STN,LINE),U,3),0,0),",")

                   SET CC=CC+$PIECE(^(LINE),U,3)

 +10               if $PIECE(^TMP($JOB,"N",STN,LINE),U,2)>0

                       WRITE ?46,$FNUMBER($JUSTIFY(($PIECE(^(LINE),U,3))/($PIECE(^(LINE),U,2)),0,0),",")

 +11               WRITE ?55,$PIECE(^TMP($JOB,"N",STN,LINE),U,4)

                   SET CD=CD+$PIECE(^(LINE),U,4)

 +12               WRITE ?62,$PIECE(^TMP($JOB,"N",STN,LINE),U,5)

                   SET CE=CE+$PIECE(^(LINE),U,5)

 +13               WRITE ?69,$PIECE(^TMP($JOB,"N",STN,LINE),U,6)

                   SET CF=CF+$PIECE(^(LINE),U,6)

 +14               WRITE ?76,$PIECE(^TMP($JOB,"N",STN,LINE),U,7)

                   SET CG=CG+$PIECE(^(LINE),U,7)

 +15               SET CH=CH+$PIECE(^TMP($JOB,"N",STN,LINE),U,8)

 +16               SET CI=CI+$PIECE(^TMP($JOB,"N",STN,LINE),U,9)

 +17               SET CJ=CJ+$PIECE(^TMP($JOB,"N",STN,LINE),U,10)

 +18               SET CK=CK+$PIECE(^TMP($JOB,"N",STN,LINE),U,11)

 +19               SET CL=CL+$PIECE(^TMP($JOB,"N",STN,LINE),U,12)

 +20               SET CM=CM+$PIECE(^TMP($JOB,"N",STN,LINE),U,16)

 +21               IF IOM>120

                       Begin DoDot:2

 +22                       WRITE ?83,$PIECE(^TMP($JOB,"N",STN,LINE),U,8)

 +23                       WRITE ?90,$PIECE(^TMP($JOB,"N",STN,LINE),U,9)

 +24                       WRITE ?97,$PIECE(^TMP($JOB,"N",STN,LINE),U,10)

 +25                       WRITE ?104,$PIECE(^TMP($JOB,"N",STN,LINE),U,11)

 +26                       WRITE ?112,$PIECE(^TMP($JOB,"N",STN,LINE),U,12)

 +27                       WRITE ?120,$PIECE(^TMP($JOB,"N",STN,LINE),U,16)

                       End DoDot:2

 +28               SET LINEP=LINE

               End DoDot:1

 +29       QUIT 

SUM       ;Print summary for group

 +1        if FL=1

               QUIT 

 +2        IF LINEP'=""

               Begin DoDot:1

 +3                IF $Y+13>IOSL

                       IF IOST["C-"

                           DO CHK

                           if FL=1

                               QUIT 

 +4                SET GROUPT=CA_U_CB_U_(CA+CB)_U_$JUSTIFY(CC,0,0)_U_CD_U_CE_U_CF_U_CG_U_CH_U_CI_U_CJ_U_CK_U_CL_U_CM

 +5                WRITE !,LN,!

 +6                WRITE ?21,CA,?26,CB,?31,(CA+CB),?37,$FNUMBER($JUSTIFY(CC,0,0),","),?55,CD,?62,CE,?69,CF,?76,CG

 +7                IF IOM>120

                       WRITE ?83,CH,?90,CI,?97,CJ,?104,CK,?112,CL,?120,CM

 +8                WRITE !

 +9                DO LBLG

 +10               SET ^TMP($JOB,"NS",STN,GROUP,STN)=GROUPT

 +11               SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

               End DoDot:1

               if FL=1

                   QUIT 

 +12       if $GET(LINEP)'="999 ZL"

               QUIT 

 +13       DO FSUM

           SET RMPRSUM=1

           DO HDR

           KILL RMPRSUM

 +14       WRITE !!,"STATION SUMMARY (2529-3 NEW ACTIVITIES)"

 +15       WRITE !,?21,"VA",?31,"Com",?41,"Total",?51,"Cost",?61

 +16       WRITE "Ave Com",?71,"Elg Ref $"

 +17       WRITE !,LN

 +18       WRITE !,?21,$FNUMBER(CA,","),?31,$FNUMBER(CB,","),?41,$FNUMBER((CA+CB),","),?51,"$"_$FNUMBER($JUSTIFY(CC,0,0),",")

 +19       IF CB>0

               WRITE ?61,"$"_$FNUMBER($JUSTIFY((CC/CB),0,0),",")

 +20       IF CM>0

               WRITE ?71,"$"_$FNUMBER($JUSTIFY(CM,0,0),",")

 +21       WRITE !,LN,!!

 +22       WRITE ?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"

 +23       WRITE !,LN,!,?21,CD,?31,CE,?41,CF,?51,CG

 +24       WRITE !,LN

 +25       WRITE !,?21,"SPEC LEG",?31,"A&A",?41,"PHC",?51,"ELG REF",?61,"NEW"

 +26       WRITE !,LN,!,?21,CH,?31,CI,?41,CJ,?51,CK,?61,CL,!,LN

 +27       WRITE !,?21,"Total Disability: ",$FNUMBER((CD+CE+CF+CG),","),?47,"Unique SSN: ",SSNCT,!

 +28       SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0

 +29       IF IOST["C-"

               DO CHK

 +30       QUIT 

LBLG      ;group description for final summary

 +1        IF $EXTRACT(LINEP,0,3)=100

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 WHEELCHAIRS AND ACCESSORIES"

 +2        IF $EXTRACT(LINEP,0,3)=200

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 ARTIFICIAL LEGS"

 +3        IF $EXTRACT(LINEP,0,3)=300

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"

 +4        IF $EXTRACT(LINEP,0,3)=400

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 ORTHOSIS/ORTHOTICS"

 +5        IF $EXTRACT(LINEP,0,3)=500

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 SHOES/ORTHOTICS"

 +6        IF $EXTRACT(LINEP,0,3)=600

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 SENSORI-NEURO AIDS"

 +7        IF $EXTRACT(LINEP,0,3)=700

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 RESTORATIONS"

 +8        IF $EXTRACT(LINEP,0,3)=800

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 OXYGEN AND RESPIRATORY"

 +9        IF $EXTRACT(LINEP,0,3)=900

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 MEDICAL EQUIPMENT"

 +10       IF $EXTRACT(LINEP,0,3)=910

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"

 +11       IF $EXTRACT(LINEP,0,3)=920

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 HOME DIALYSIS PROGRAM"

 +12       IF $EXTRACT(LINEP,0,3)=930

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 ADAPTIVE EQUIPMENT"

 +13       IF $EXTRACT(LINEP,0,3)=940

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 HISA"

 +14       IF $EXTRACT(LINEP,0,3)=960

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 SURGICAL IMPLANTS"

 +15       IF $EXTRACT(LINEP,0,3)=970

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 BIOLOGICAL IMPLANTS"

 +16       IF $EXTRACT(LINEP,0,3)=999

               SET GROUP=$EXTRACT(LINEP,0,3)_" 2529-3 MISC"

 +17       QUIT 

LBL       ;label for group

 +1        IF $EXTRACT(LINE,0,3)=100

               WRITE !,"2529-3 WHEELCHAIRS AND ACCESSORIES"

 +2        IF $EXTRACT(LINE,0,3)=200

               WRITE !,"2529-3 ARTIFICIAL LEGS"

 +3        IF $EXTRACT(LINE,0,3)=300

               WRITE !,"2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"

 +4        IF $EXTRACT(LINE,0,3)=400

               WRITE !,"2529-3 ORTHOSIS/ORTHOTICS"

 +5        IF $EXTRACT(LINE,0,3)=500

               IF IOST'["C-"

                   WRITE @IOF

                   DO HDR

                   WRITE !,"2529-3 SHOES/ORTHOTICS"

 +6        IF $EXTRACT(LINE,0,3)=500

               IF IOST["C-"

                   WRITE !,"2529-3 SHOES/ORTHOTICS"

 +7        IF $EXTRACT(LINE,0,3)=600

               WRITE !,"2529-3 SENSORI-NEURO AIDS"

 +8        IF $EXTRACT(LINE,0,3)=700

               WRITE !,"2529-3 RESTORATIONS"

 +9        IF $EXTRACT(LINE,0,3)=800

               WRITE !,"2529-3 OXYGEN AND RESPIRATORY"

 +10       IF $EXTRACT(LINE,0,3)=900

               IF IOST'["C-"

                   WRITE @IOF

                   DO HDR

                   WRITE !,"2529-3 MEDICAL EQUIPMENT"

 +11       IF $EXTRACT(LINE,0,3)=900

               IF IOST["C-"

                   WRITE !,"2529-3 MEDICAL EQUIPMENT"

 +12       IF $EXTRACT(LINE,0,3)=910

               WRITE !,"2529-3 ALL OTHER SUPPLIES AND EQUIPMENT"

 +13       IF $EXTRACT(LINE,0,3)=920

               WRITE !,"2529-3 HOME DIALYSIS PROGRAM"

 +14       IF $EXTRACT(LINE,0,3)=930

               WRITE !,"2529-3 ADAPTIVE EQUIPMENT"

 +15       IF $EXTRACT(LINE,0,3)=940

               WRITE !,"2529-3 HISA"

 +16       IF $EXTRACT(LINE,0,3)=960

               WRITE !,"2529-3 SURGICAL IMPLANTS"

 +17       IF $EXTRACT(LINE,0,3)=970

               WRITE !,"2529-3 BIOLOGICAL IMPLANTS"

 +18       IF $EXTRACT(LINE,0,3)=999

               IF IOST'["C-"

                   WRITE @IOF

                   DO HDR

                   WRITE !,"2529-3 MISC"

 +19       IF $EXTRACT(LINE,0,3)=999

               IF IOST["C-"

                   WRITE !,"2529-3 MISC"

 +20       QUIT 

FSUM      ;final summay on New Worksheets STATION

 +1        SET H=0

 +2        FOR 

               SET H=$ORDER(^TMP($JOB,"NS",STN,H))

               if H=""

                   QUIT 

               Begin DoDot:1

 +3                SET H1=0

                   SET H2=0

 +4                FOR 

                       SET H1=$ORDER(^TMP($JOB,"NS",STN,H,H1))

                       if H1=""

                           QUIT 

                       Begin DoDot:2

 +5                        if H1'=STN

                               QUIT 

 +6                        SET H2=^TMP($JOB,"NS",STN,H,H1)

 +7                        SET CA=CA+$PIECE(H2,U,1)

 +8                        SET CB=CB+$PIECE(H2,U,2)

 +9                        SET CC=CC+$PIECE(H2,U,4)

 +10                       SET CD=CD+$PIECE(H2,U,5)

 +11                       SET CE=CE+$PIECE(H2,U,6)

 +12                       SET CF=CF+$PIECE(H2,U,7)

 +13                       SET CG=CG+$PIECE(H2,U,8)

 +14                       SET CH=CH+$PIECE(H2,U,9)

 +15                       SET CI=CI+$PIECE(H2,U,10)

 +16                       SET CJ=CJ+$PIECE(H2,U,11)

 +17                       SET CK=CK+$PIECE(H2,U,12)

 +18                       SET CL=CL+$PIECE(H2,U,13)

 +19                       SET CM=CM+$PIECE(H2,U,14)

                       End DoDot:2

               End DoDot:1

 +20       QUIT 

CHK       ;

 +1        KILL DIR

           WRITE !!

           SET DIR(0)="E"

           DO ^DIR

           if +Y'>0

               SET FL=1

 +2        WRITE @IOF

 +3        QUIT 

 +4       ;END