RMPRN6PT ;HINES/HNC -PRINT NPPD NEW WORKSHEETS ;2/14/98
;;3.0;PROSTHETICS;**31,32,39,51,57,84,103,144**;Feb 09, 1996;Build 17
;
; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines
; AAC Patch 84, 02-25-04, Change Description for 600
; AAC PATCH 103, 01-17-05 NPPD CATEGORIES/LINES - NEW and REPAIR
;
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 @IOF
W !,"REPORT OF NEW PROSTHETICS ACTIVITIES"
;header based on sort select
W !,$$HDR^RMPRN6S(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",?6,"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,?6,$E($P(^TMP($J,"N",STN,LINE),U,15),1,15)
.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 Z"
D FSUM S RMPRSUM=1 W @IOF D HDR K RMPRSUM
W !!,"STATION SUMMARY (NEW ACTIVITIES)"
;W !,$$HDR^RMPRN6S(RMPRDET)
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)_" WHEELCHAIRS AND ACCESSORIES"
I $E(LINEP,0,3)=200 S GROUP=$E(LINEP,0,3)_" ARTIFICIAL LEGS"
I $E(LINEP,0,3)=300 S GROUP=$E(LINEP,0,3)_" ARTIFICIAL ARMS AND TERMINAL DEVICES"
I $E(LINEP,0,3)=400 S GROUP=$E(LINEP,0,3)_" ORTHOSIS/ORTHOTICS"
I $E(LINEP,0,3)=500 S GROUP=$E(LINEP,0,3)_" SHOES/ORTHOTICS"
I $E(LINEP,0,3)=600 S GROUP=$E(LINEP,0,3)_" SENSORI-NEURO AIDS"
I $E(LINEP,0,3)=700 S GROUP=$E(LINEP,0,3)_" RESTORATIONS"
I $E(LINEP,0,3)=800 S GROUP=$E(LINEP,0,3)_" OXYGEN AND RESPIRATORY"
I $E(LINEP,0,3)=900 S GROUP=$E(LINEP,0,3)_" MEDICAL EQUIPMENT"
I $E(LINEP,0,3)=910 S GROUP=$E(LINEP,0,3)_" ALL OTHER SUPPLIES AND EQUIPMENT"
I $E(LINEP,0,3)=920 S GROUP=$E(LINEP,0,3)_" HOME DIALYSIS PROGRAM"
I $E(LINEP,0,3)=930 S GROUP=$E(LINEP,0,3)_" ADAPTIVE EQUIPMENT"
I $E(LINEP,0,3)=940 S GROUP=$E(LINEP,0,3)_" HISA"
I $E(LINEP,0,3)=960 S GROUP=$E(LINEP,0,3)_" SURGICAL IMPLANTS"
I $E(LINEP,0,3)=970 S GROUP=$E(LINEP,0,3)_" BIOLOGICAL IMPLANTS"
I $E(LINEP,0,3)=999 S GROUP=$E(LINEP,0,3)_" MISC"
Q
LBL ;label for group
I $E(LINE,0,3)=100 W !,"WHEELCHAIRS AND ACCESSORIES"
I $E(LINE,0,3)=200 W !,"ARTIFICIAL LEGS"
I $E(LINE,0,3)=300 W !,"ARTIFICIAL ARMS AND TERMINAL DEVICES"
I $E(LINE,0,3)=400 W !,"ORTHOSIS/ORTHOTICS"
I $E(LINE,0,3)=500,IOST'["C-" W @IOF D HDR W !,"SHOES/ORTHOTICS"
I $E(LINE,0,3)=500,IOST["C-" W !,"SHOES/ORTHOTICS"
I $E(LINE,0,3)=600 W !,"SENSORI-NEURO AIDS"
I $E(LINE,0,3)=700 W !,"RESTORATIONS"
I $E(LINE,0,3)=800 W !,"OXYGEN AND RESPIRATORY"
I $E(LINE,0,3)=900,IOST'["C-" W @IOF D HDR W !,"MEDICAL EQUIPMENT"
I $E(LINE,0,3)=900,IOST["C-" W !,"MEDICAL EQUIPMENT"
I $E(LINE,0,3)=910 W !,"ALL OTHER SUPPLIES AND EQUIPMENT"
I $E(LINE,0,3)=920 W !,"HOME DIALYSIS PROGRAM"
I $E(LINE,0,3)=930 W !,"ADAPTIVE EQUIPMENT"
I $E(LINE,0,3)=940 W !,"HISA"
I $E(LINE,0,3)=960 W !,"SURGICAL IMPLANTS"
I $E(LINE,0,3)=970 W !,"BIOLOGICAL IMPLANTS"
I $E(LINE,0,3)=999,IOST'["C-" W @IOF D HDR W !,"MISC"
I $E(LINE,0,3)=999,IOST["C-" W !,"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 ---[H[J[2J[HRMPRN6PT 6427 printed Sep 23, 2025@20:11:19 Page 2
RMPRN6PT ;HINES/HNC -PRINT NPPD NEW WORKSHEETS ;2/14/98
+1 ;;3.0;PROSTHETICS;**31,32,39,51,57,84,103,144**;Feb 09, 1996;Build 17
+2 ;
+3 ; AAC Patch 84, 02-25-04, additions, deletions and change descriptions for Groups and lines
+4 ; AAC Patch 84, 02-25-04, Change Description for 600
+5 ; AAC PATCH 103, 01-17-05 NPPD CATEGORIES/LINES - NEW and REPAIR
+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 ;W @IOF
+2 WRITE !,"REPORT OF NEW PROSTHETICS ACTIVITIES"
+3 ;header based on sort select
+4 WRITE !,$$HDR^RMPRN6S(RMPRDET)
+5 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)
+6 WRITE !,?10,"STATION: ",STN
+7 ;RMPRSUM if summary header
+8 if $GET(RMPRSUM)
QUIT
+9 WRITE !!
+10 WRITE !,"Line",?6,"Item",?21,"VA",?26,"Com",?31,"Total",?37,"Cost",?46
+11 WRITE "Ave Com",?54
+12 WRITE "SC/OP",?61,"NSC/OP",?68,"SC/IP",?74,"NSC/IP"
+13 IF IOM>120
Begin DoDot:1
+14 WRITE ?83,"SP LEG"
+15 WRITE ?90,"A&A",?97,"PHC",?104,"ELG REF",?112,"NEW",?120,"$ELG REF"
End DoDot:1
+16 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,?6,$EXTRACT($PIECE(^TMP($JOB,"N",STN,LINE),U,15),1,15)
+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 Z"
QUIT
+13 DO FSUM
SET RMPRSUM=1
WRITE @IOF
DO HDR
KILL RMPRSUM
+14 WRITE !!,"STATION SUMMARY (NEW ACTIVITIES)"
+15 ;W !,$$HDR^RMPRN6S(RMPRDET)
+16 WRITE !,?21,"VA",?31,"Com",?41,"Total",?51,"Cost",?61
+17 WRITE "Ave Com",?71,"Elg Ref $"
+18 WRITE !,LN
+19 WRITE !,?21,$FNUMBER(CA,","),?31,$FNUMBER(CB,","),?41,$FNUMBER((CA+CB),","),?51,"$"_$FNUMBER($JUSTIFY(CC,0,0),",")
+20 IF CB>0
WRITE ?61,"$"_$FNUMBER($JUSTIFY((CC/CB),0,0),",")
+21 IF CM>0
WRITE ?71,"$"_$FNUMBER($JUSTIFY(CM,0,0),",")
+22 WRITE !,LN,!!
+23 WRITE ?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"
+24 WRITE !,LN,!,?21,CD,?31,CE,?41,CF,?51,CG
+25 WRITE !,LN
+26 WRITE !,?21,"SPEC LEG",?31,"A&A",?41,"PHC",?51,"ELG REF",?61,"NEW"
+27 WRITE !,LN,!,?21,CH,?31,CI,?41,CJ,?51,CK,?61,CL,!,LN
+28 WRITE !,?21,"Total Disability: ",$FNUMBER((CD+CE+CF+CG),","),?47,"Unique SSN: ",SSNCT,!
+29 SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
+30 IF IOST["C-"
DO CHK
+31 QUIT
LBLG ;group description for final summary
+1 IF $EXTRACT(LINEP,0,3)=100
SET GROUP=$EXTRACT(LINEP,0,3)_" WHEELCHAIRS AND ACCESSORIES"
+2 IF $EXTRACT(LINEP,0,3)=200
SET GROUP=$EXTRACT(LINEP,0,3)_" ARTIFICIAL LEGS"
+3 IF $EXTRACT(LINEP,0,3)=300
SET GROUP=$EXTRACT(LINEP,0,3)_" ARTIFICIAL ARMS AND TERMINAL DEVICES"
+4 IF $EXTRACT(LINEP,0,3)=400
SET GROUP=$EXTRACT(LINEP,0,3)_" ORTHOSIS/ORTHOTICS"
+5 IF $EXTRACT(LINEP,0,3)=500
SET GROUP=$EXTRACT(LINEP,0,3)_" SHOES/ORTHOTICS"
+6 IF $EXTRACT(LINEP,0,3)=600
SET GROUP=$EXTRACT(LINEP,0,3)_" SENSORI-NEURO AIDS"
+7 IF $EXTRACT(LINEP,0,3)=700
SET GROUP=$EXTRACT(LINEP,0,3)_" RESTORATIONS"
+8 IF $EXTRACT(LINEP,0,3)=800
SET GROUP=$EXTRACT(LINEP,0,3)_" OXYGEN AND RESPIRATORY"
+9 IF $EXTRACT(LINEP,0,3)=900
SET GROUP=$EXTRACT(LINEP,0,3)_" MEDICAL EQUIPMENT"
+10 IF $EXTRACT(LINEP,0,3)=910
SET GROUP=$EXTRACT(LINEP,0,3)_" ALL OTHER SUPPLIES AND EQUIPMENT"
+11 IF $EXTRACT(LINEP,0,3)=920
SET GROUP=$EXTRACT(LINEP,0,3)_" HOME DIALYSIS PROGRAM"
+12 IF $EXTRACT(LINEP,0,3)=930
SET GROUP=$EXTRACT(LINEP,0,3)_" ADAPTIVE EQUIPMENT"
+13 IF $EXTRACT(LINEP,0,3)=940
SET GROUP=$EXTRACT(LINEP,0,3)_" HISA"
+14 IF $EXTRACT(LINEP,0,3)=960
SET GROUP=$EXTRACT(LINEP,0,3)_" SURGICAL IMPLANTS"
+15 IF $EXTRACT(LINEP,0,3)=970
SET GROUP=$EXTRACT(LINEP,0,3)_" BIOLOGICAL IMPLANTS"
+16 IF $EXTRACT(LINEP,0,3)=999
SET GROUP=$EXTRACT(LINEP,0,3)_" MISC"
+17 QUIT
LBL ;label for group
+1 IF $EXTRACT(LINE,0,3)=100
WRITE !,"WHEELCHAIRS AND ACCESSORIES"
+2 IF $EXTRACT(LINE,0,3)=200
WRITE !,"ARTIFICIAL LEGS"
+3 IF $EXTRACT(LINE,0,3)=300
WRITE !,"ARTIFICIAL ARMS AND TERMINAL DEVICES"
+4 IF $EXTRACT(LINE,0,3)=400
WRITE !,"ORTHOSIS/ORTHOTICS"
+5 IF $EXTRACT(LINE,0,3)=500
IF IOST'["C-"
WRITE @IOF
DO HDR
WRITE !,"SHOES/ORTHOTICS"
+6 IF $EXTRACT(LINE,0,3)=500
IF IOST["C-"
WRITE !,"SHOES/ORTHOTICS"
+7 IF $EXTRACT(LINE,0,3)=600
WRITE !,"SENSORI-NEURO AIDS"
+8 IF $EXTRACT(LINE,0,3)=700
WRITE !,"RESTORATIONS"
+9 IF $EXTRACT(LINE,0,3)=800
WRITE !,"OXYGEN AND RESPIRATORY"
+10 IF $EXTRACT(LINE,0,3)=900
IF IOST'["C-"
WRITE @IOF
DO HDR
WRITE !,"MEDICAL EQUIPMENT"
+11 IF $EXTRACT(LINE,0,3)=900
IF IOST["C-"
WRITE !,"MEDICAL EQUIPMENT"
+12 IF $EXTRACT(LINE,0,3)=910
WRITE !,"ALL OTHER SUPPLIES AND EQUIPMENT"
+13 IF $EXTRACT(LINE,0,3)=920
WRITE !,"HOME DIALYSIS PROGRAM"
+14 IF $EXTRACT(LINE,0,3)=930
WRITE !,"ADAPTIVE EQUIPMENT"
+15 IF $EXTRACT(LINE,0,3)=940
WRITE !,"HISA"
+16 IF $EXTRACT(LINE,0,3)=960
WRITE !,"SURGICAL IMPLANTS"
+17 IF $EXTRACT(LINE,0,3)=970
WRITE !,"BIOLOGICAL IMPLANTS"
+18 IF $EXTRACT(LINE,0,3)=999
IF IOST'["C-"
WRITE @IOF
DO HDR
WRITE !,"MISC"
+19 IF $EXTRACT(LINE,0,3)=999
IF IOST["C-"
WRITE !,"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
