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 Dec 13, 2024@02:35:17 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
