- RMPRN7PR ;HINES/HNC -PRINT REPAIR WORKSHEETS ;2/14/01
- ;;3.0;PROSTHETICS;**57,84,103**;Feb 09, 1996
- ;
- ; AAC Patch 84 2/25/04 additions, deletions and change descriptions for Groups and lines
- ; AAC Patch 84 - New Group description changes, R60
- ; - Repair Group description changes, R60
- ; AAC Patch 103 - 1/17/05 NPPD CATEGORIES/LINES - NEW and REPAIR UPDATES
- ;
- K ^TMP($J,"RS")
- S STN=1
- F S STN=$O(^TMP($J,"R",STN)) Q:STN="" D HDR,CDATA,SUM
- Q
- HDR ;leave this form feed alone
- W @IOF
- W !,"REPORT OF 2529-3 REPAIR PROSTHETICS ACTIVITIES"
- ;header depending on sort selected
- W !,$$HDR^RMPRN7S(RMPRDET)
- S Y=DATE(1) D DD^%DT W !,Y," - " S Y=DATE(2) D DD^%DT W Y
- 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 ;
- Q:FL=1
- S LINE="",LINEP=""
- S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
- F S LINE=$O(^TMP($J,"R",STN,LINE)) Q:LINE="" Q:FL=1 D
- .I $E(LINE,0,3)'=$E(LINEP,0,3) D SUM Q:FL=1 D LBLR
- .W !,LINE,?7,$E($P(^TMP($J,"R",STN,LINE),U,15),1,14)
- .W ?21,$P(^TMP($J,"R",STN,LINE),U,1) S CA=CA+$P(^(LINE),U,1)
- .W ?26,$P(^TMP($J,"R",STN,LINE),U,2) S CB=CB+$P(^(LINE),U,2)
- .W ?31,$P(^TMP($J,"R",STN,LINE),U,1)+($P(^TMP($J,"R",STN,LINE),U,2))
- .W ?37,$FN($J($P(^TMP($J,"R",STN,LINE),U,3),0,0),",") S CC=CC+$P(^(LINE),U,3)
- .W:$P(^TMP($J,"R",STN,LINE),U,2)>0 ?46,$FN($J(($P(^(LINE),U,3))/($P(^(LINE),U,2)),0,0),",")
- .W ?55,$P(^TMP($J,"R",STN,LINE),U,4) S CD=CD+$P(^(LINE),U,4)
- .W ?62,$P(^TMP($J,"R",STN,LINE),U,5) S CE=CE+$P(^(LINE),U,5)
- .W ?69,$P(^TMP($J,"R",STN,LINE),U,6) S CF=CF+$P(^(LINE),U,6)
- .W ?76,$P(^TMP($J,"R",STN,LINE),U,7) S CG=CG+$P(^(LINE),U,7)
- .S CH=CH+$P(^TMP($J,"R",STN,LINE),U,8)
- .S CI=CI+$P(^TMP($J,"R",STN,LINE),U,9)
- .S CJ=CJ+$P(^TMP($J,"R",STN,LINE),U,10)
- .S CK=CK+$P(^TMP($J,"R",STN,LINE),U,11)
- .S CL=CL+$P(^TMP($J,"R",STN,LINE),U,12)
- .S CM=CM+$P(^TMP($J,"R",STN,LINE),U,16)
- .I IOM>120 D
- ..W ?83,$P(^TMP($J,"R",STN,LINE),U,8)
- ..W ?90,$P(^TMP($J,"R",STN,LINE),U,9)
- ..W ?97,$P(^TMP($J,"R",STN,LINE),U,10)
- ..W ?104,$P(^TMP($J,"R",STN,LINE),U,11)
- ..W ?112,$P(^TMP($J,"R",STN,LINE),U,12)
- ..W ?120,$P(^TMP($J,"R",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,"RS",STN,GROUP,STN)=GROUPT
- .S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
- Q:$G(LINEP)'="R99 ZL"
- D FSUM S RMPRSUM=1 D HDR K RMPRSUM
- W !!,"STATION SUMMARY (2529-3 REPAIR ACTIVITIES)"
- ;W !,$$HDR^RMPRN7S(RMPRDET)
- W !,?21,"VA",?31,"Com",?41,"Total",?51,"Cost",?61
- W "Ave Com",?71,"Elg Ref $"
- W !,LN
- W !,?21,CA,?31,CB,?41,(CA+CB),?51,"$"_$FN($J(CC,0,0),",")
- W ?61
- I CB>0 W "$"_$FN($J((CC/CB),0,0),",")
- W ?71
- I CM>0 W "$"_$FN($J((CM),0,0),",")
- W !,LN,!
- W !,?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"
- W !,LN,!
- W ?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: ",(CD+CE+CF+CG),!,LN,!
- S (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL)=0
- I IOST["C-" D CHK
- Q
- LBLG ;group description fo final repair summary
- I $E(LINEP,0,3)="R07" S GROUP=$E(LINEP,0,3)_" HEARING AID, LOCAL REPAIRS"
- I $E(LINEP,0,3)="R10" S GROUP=$E(LINEP,0,3)_" WHEELCHAIRS AND ACCESSORIES"
- I $E(LINEP,0,3)="R20" S GROUP=$E(LINEP,0,3)_" ARTIFICIAL LEGS"
- I $E(LINEP,0,3)="R30" S GROUP=$E(LINEP,0,3)_" ARTIFICIAL ARMS AND TERMINAL DEVICES"
- I $E(LINEP,0,3)="R40" S GROUP=$E(LINEP,0,3)_" ORTHOSIS"
- I $E(LINEP,0,3)="R50" S GROUP=$E(LINEP,0,3)_" SHOES/ORTHOTICS"
- I $E(LINEP,0,3)="R60" S GROUP=$E(LINEP,0,3)_" SENSORI-NEURO AIDS"
- I $E(LINEP,0,3)="R70" S GROUP=$E(LINEP,0,3)_" HOME DIALYSIS EQUIPMENT"
- I $E(LINEP,0,3)="R80" S GROUP=$E(LINEP,0,3)_" MEDICAL EQUIPMENT"
- I $E(LINEP,0,3)="R90" S GROUP=$E(LINEP,0,3)_" ALL OTHER"
- I $E(LINEP,0,3)="R91" S GROUP=$E(LINEP,0,3)_" OXYGEN & RESPIRATORY"
- I $E(LINEP,0,3)="R92" S GROUP=$E(LINEP,0,3)_" AUTO & VAN EQUIP"
- I $E(LINEP,0,3)="R99" S GROUP=$E(LINEP,0,3)_" MISC"
- Q
- LBLR ;label for repair group
- I $E(LINE,0,3)="R10" W !,"2529-3 WHEELCHAIRS AND ACCESSORIES"
- I $E(LINE,0,3)="R20" W !,"2529-3 ARTIFICIAL LEGS"
- I $E(LINE,0,3)="R30" W !,"2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"
- I $E(LINE,0,3)="R40" W !,"2529-3 ORTHOSIS"
- I $E(LINE,0,3)="R50" W !,"2529-3 SHOES/ORTHOTICS"
- I $E(LINE,0,3)="R60" W !,"2529-3 SENSORI-NEURO AIDS"
- I $E(LINE,0,3)="R70" W !,"2529-3 HOME DIALYSIS EQUIPMENT"
- I $E(LINE,0,3)="R80",IOST'["C-" D HDR W !,"2529-3 MEDICAL EQUIPMENT"
- I $E(LINE,0,3)="R80",IOST["C-" W !,"2529-3 MEDICAL EQUIPMENT"
- I $E(LINE,0,3)="R90" W !,"2529-3 ALL OTHER"
- I $E(LINE,0,3)="R91" W !,"2529-3 OXYGEN & RESPIRATORY"
- I $E(LINE,0,3)="R92" W !,"2529-3 AUTO & VAN EQUIP"
- I $E(LINE,0,3)="R99" W !,"2529-3 MISC"
- Q
- FSUM ;final summay on Repair Worksheets STATION
- S H=0
- F S H=$O(^TMP($J,"RS",STN,H)) Q:H="" D
- .S H1=0,H2=0
- .F S H1=$O(^TMP($J,"RS",STN,H,H1)) Q:H1="" D
- ..Q:H1'=STN
- ..S H2=^TMP($J,"RS",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[HRMPRN7PR 5920 printed Feb 19, 2025@00:01:45 Page 2
- RMPRN7PR ;HINES/HNC -PRINT REPAIR WORKSHEETS ;2/14/01
- +1 ;;3.0;PROSTHETICS;**57,84,103**;Feb 09, 1996
- +2 ;
- +3 ; AAC Patch 84 2/25/04 additions, deletions and change descriptions for Groups and lines
- +4 ; AAC Patch 84 - New Group description changes, R60
- +5 ; - Repair Group description changes, R60
- +6 ; AAC Patch 103 - 1/17/05 NPPD CATEGORIES/LINES - NEW and REPAIR UPDATES
- +7 ;
- +8 KILL ^TMP($JOB,"RS")
- +9 SET STN=1
- +10 FOR
- SET STN=$ORDER(^TMP($JOB,"R",STN))
- if STN=""
- QUIT
- DO HDR
- DO CDATA
- DO SUM
- +11 QUIT
- HDR ;leave this form feed alone
- +1 WRITE @IOF
- +2 WRITE !,"REPORT OF 2529-3 REPAIR PROSTHETICS ACTIVITIES"
- +3 ;header depending on sort selected
- +4 WRITE !,$$HDR^RMPRN7S(RMPRDET)
- +5 SET Y=DATE(1)
- DO DD^%DT
- WRITE !,Y," - "
- SET Y=DATE(2)
- DO DD^%DT
- WRITE Y
- +6 WRITE !,?10,"STATION: ",STN
- +7 ;RMPRSUM if summary header
- +8 if $GET(RMPRSUM)
- QUIT
- +9 WRITE !!
- +10 WRITE !,"Line",?7,"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 if FL=1
- QUIT
- +2 SET LINE=""
- SET LINEP=""
- +3 SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL,CM)=0
- +4 FOR
- SET LINE=$ORDER(^TMP($JOB,"R",STN,LINE))
- if LINE=""
- QUIT
- if FL=1
- QUIT
- Begin DoDot:1
- +5 IF $EXTRACT(LINE,0,3)'=$EXTRACT(LINEP,0,3)
- DO SUM
- if FL=1
- QUIT
- DO LBLR
- +6 WRITE !,LINE,?7,$EXTRACT($PIECE(^TMP($JOB,"R",STN,LINE),U,15),1,14)
- +7 WRITE ?21,$PIECE(^TMP($JOB,"R",STN,LINE),U,1)
- SET CA=CA+$PIECE(^(LINE),U,1)
- +8 WRITE ?26,$PIECE(^TMP($JOB,"R",STN,LINE),U,2)
- SET CB=CB+$PIECE(^(LINE),U,2)
- +9 WRITE ?31,$PIECE(^TMP($JOB,"R",STN,LINE),U,1)+($PIECE(^TMP($JOB,"R",STN,LINE),U,2))
- +10 WRITE ?37,$FNUMBER($JUSTIFY($PIECE(^TMP($JOB,"R",STN,LINE),U,3),0,0),",")
- SET CC=CC+$PIECE(^(LINE),U,3)
- +11 if $PIECE(^TMP($JOB,"R",STN,LINE),U,2)>0
- WRITE ?46,$FNUMBER($JUSTIFY(($PIECE(^(LINE),U,3))/($PIECE(^(LINE),U,2)),0,0),",")
- +12 WRITE ?55,$PIECE(^TMP($JOB,"R",STN,LINE),U,4)
- SET CD=CD+$PIECE(^(LINE),U,4)
- +13 WRITE ?62,$PIECE(^TMP($JOB,"R",STN,LINE),U,5)
- SET CE=CE+$PIECE(^(LINE),U,5)
- +14 WRITE ?69,$PIECE(^TMP($JOB,"R",STN,LINE),U,6)
- SET CF=CF+$PIECE(^(LINE),U,6)
- +15 WRITE ?76,$PIECE(^TMP($JOB,"R",STN,LINE),U,7)
- SET CG=CG+$PIECE(^(LINE),U,7)
- +16 SET CH=CH+$PIECE(^TMP($JOB,"R",STN,LINE),U,8)
- +17 SET CI=CI+$PIECE(^TMP($JOB,"R",STN,LINE),U,9)
- +18 SET CJ=CJ+$PIECE(^TMP($JOB,"R",STN,LINE),U,10)
- +19 SET CK=CK+$PIECE(^TMP($JOB,"R",STN,LINE),U,11)
- +20 SET CL=CL+$PIECE(^TMP($JOB,"R",STN,LINE),U,12)
- +21 SET CM=CM+$PIECE(^TMP($JOB,"R",STN,LINE),U,16)
- +22 IF IOM>120
- Begin DoDot:2
- +23 WRITE ?83,$PIECE(^TMP($JOB,"R",STN,LINE),U,8)
- +24 WRITE ?90,$PIECE(^TMP($JOB,"R",STN,LINE),U,9)
- +25 WRITE ?97,$PIECE(^TMP($JOB,"R",STN,LINE),U,10)
- +26 WRITE ?104,$PIECE(^TMP($JOB,"R",STN,LINE),U,11)
- +27 WRITE ?112,$PIECE(^TMP($JOB,"R",STN,LINE),U,12)
- +28 WRITE ?120,$PIECE(^TMP($JOB,"R",STN,LINE),U,16)
- End DoDot:2
- +29 SET LINEP=LINE
- End DoDot:1
- +30 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,"RS",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)'="R99 ZL"
- QUIT
- +13 DO FSUM
- SET RMPRSUM=1
- DO HDR
- KILL RMPRSUM
- +14 WRITE !!,"STATION SUMMARY (2529-3 REPAIR ACTIVITIES)"
- +15 ;W !,$$HDR^RMPRN7S(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,CA,?31,CB,?41,(CA+CB),?51,"$"_$FNUMBER($JUSTIFY(CC,0,0),",")
- +20 WRITE ?61
- +21 IF CB>0
- WRITE "$"_$FNUMBER($JUSTIFY((CC/CB),0,0),",")
- +22 WRITE ?71
- +23 IF CM>0
- WRITE "$"_$FNUMBER($JUSTIFY((CM),0,0),",")
- +24 WRITE !,LN,!
- +25 WRITE !,?21,"SC/OP",?31,"NSC/OP",?41,"SC/IP",?51,"NSC/IP"
- +26 WRITE !,LN,!
- +27 WRITE ?21,CD,?31,CE,?41,CF,?51,CG
- +28 WRITE !,LN
- +29 WRITE !,?21,"SPEC LEG",?31,"A&A",?41,"PHC",?51,"ELG REF",?61,"NEW"
- +30 WRITE !,LN,!,?21,CH,?31,CI,?41,CJ,?51,CK,?61,CL,!,LN
- +31 WRITE !,?21,"Total Disability: ",(CD+CE+CF+CG),!,LN,!
- +32 SET (CA,CB,CC,CD,CE,CF,CG,CH,CI,CJ,CK,CL)=0
- +33 IF IOST["C-"
- DO CHK
- +34 QUIT
- LBLG ;group description fo final repair summary
- +1 IF $EXTRACT(LINEP,0,3)="R07"
- SET GROUP=$EXTRACT(LINEP,0,3)_" HEARING AID, LOCAL REPAIRS"
- +2 IF $EXTRACT(LINEP,0,3)="R10"
- SET GROUP=$EXTRACT(LINEP,0,3)_" WHEELCHAIRS AND ACCESSORIES"
- +3 IF $EXTRACT(LINEP,0,3)="R20"
- SET GROUP=$EXTRACT(LINEP,0,3)_" ARTIFICIAL LEGS"
- +4 IF $EXTRACT(LINEP,0,3)="R30"
- SET GROUP=$EXTRACT(LINEP,0,3)_" ARTIFICIAL ARMS AND TERMINAL DEVICES"
- +5 IF $EXTRACT(LINEP,0,3)="R40"
- SET GROUP=$EXTRACT(LINEP,0,3)_" ORTHOSIS"
- +6 IF $EXTRACT(LINEP,0,3)="R50"
- SET GROUP=$EXTRACT(LINEP,0,3)_" SHOES/ORTHOTICS"
- +7 IF $EXTRACT(LINEP,0,3)="R60"
- SET GROUP=$EXTRACT(LINEP,0,3)_" SENSORI-NEURO AIDS"
- +8 IF $EXTRACT(LINEP,0,3)="R70"
- SET GROUP=$EXTRACT(LINEP,0,3)_" HOME DIALYSIS EQUIPMENT"
- +9 IF $EXTRACT(LINEP,0,3)="R80"
- SET GROUP=$EXTRACT(LINEP,0,3)_" MEDICAL EQUIPMENT"
- +10 IF $EXTRACT(LINEP,0,3)="R90"
- SET GROUP=$EXTRACT(LINEP,0,3)_" ALL OTHER"
- +11 IF $EXTRACT(LINEP,0,3)="R91"
- SET GROUP=$EXTRACT(LINEP,0,3)_" OXYGEN & RESPIRATORY"
- +12 IF $EXTRACT(LINEP,0,3)="R92"
- SET GROUP=$EXTRACT(LINEP,0,3)_" AUTO & VAN EQUIP"
- +13 IF $EXTRACT(LINEP,0,3)="R99"
- SET GROUP=$EXTRACT(LINEP,0,3)_" MISC"
- +14 QUIT
- LBLR ;label for repair group
- +1 IF $EXTRACT(LINE,0,3)="R10"
- WRITE !,"2529-3 WHEELCHAIRS AND ACCESSORIES"
- +2 IF $EXTRACT(LINE,0,3)="R20"
- WRITE !,"2529-3 ARTIFICIAL LEGS"
- +3 IF $EXTRACT(LINE,0,3)="R30"
- WRITE !,"2529-3 ARTIFICIAL ARMS AND TERMINAL DEVICES"
- +4 IF $EXTRACT(LINE,0,3)="R40"
- WRITE !,"2529-3 ORTHOSIS"
- +5 IF $EXTRACT(LINE,0,3)="R50"
- WRITE !,"2529-3 SHOES/ORTHOTICS"
- +6 IF $EXTRACT(LINE,0,3)="R60"
- WRITE !,"2529-3 SENSORI-NEURO AIDS"
- +7 IF $EXTRACT(LINE,0,3)="R70"
- WRITE !,"2529-3 HOME DIALYSIS EQUIPMENT"
- +8 IF $EXTRACT(LINE,0,3)="R80"
- IF IOST'["C-"
- DO HDR
- WRITE !,"2529-3 MEDICAL EQUIPMENT"
- +9 IF $EXTRACT(LINE,0,3)="R80"
- IF IOST["C-"
- WRITE !,"2529-3 MEDICAL EQUIPMENT"
- +10 IF $EXTRACT(LINE,0,3)="R90"
- WRITE !,"2529-3 ALL OTHER"
- +11 IF $EXTRACT(LINE,0,3)="R91"
- WRITE !,"2529-3 OXYGEN & RESPIRATORY"
- +12 IF $EXTRACT(LINE,0,3)="R92"
- WRITE !,"2529-3 AUTO & VAN EQUIP"
- +13 IF $EXTRACT(LINE,0,3)="R99"
- WRITE !,"2529-3 MISC"
- +14 QUIT
- FSUM ;final summay on Repair Worksheets STATION
- +1 SET H=0
- +2 FOR
- SET H=$ORDER(^TMP($JOB,"RS",STN,H))
- if H=""
- QUIT
- Begin DoDot:1
- +3 SET H1=0
- SET H2=0
- +4 FOR
- SET H1=$ORDER(^TMP($JOB,"RS",STN,H,H1))
- if H1=""
- QUIT
- Begin DoDot:2
- +5 if H1'=STN
- QUIT
- +6 SET H2=^TMP($JOB,"RS",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
