APCHSUTL ; IHS/CMI/LAB - UTILITIES FOR APCHS -- SUMMARY PRODUCTION COMPONENTS
;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
;
GETICDDX ;ENTRY POINT
NEW APCHXY,APCHSDSC
S APCHXY=$$ICDDX^ICDEX(APCHSICD,$G(APCHCSVD))
I $P(APCHXY,U)="-1" D
.S APCHXY=APCHSICD_U_$P($G(^ICD9(APCHSICD,0)),U,1)_U_U_$$VSTD^AUPNVUTL(APCHSICD,$G(APCHSCVD))
S APCHSDSC=$$ICDD^ICDEX($P(APCHXY,U,2),.APCHSDSC,$G(APCHCSVD))
S:APCHSICF="L" APCHSICD=$P(APCHXY,U,2)_"-"_$S($D(APCHSDSC(1)):$G(APCHSDSC(1)),1:"<DESCRIPTION field missing>")
S:APCHSICF="S" APCHSICD=$P(APCHXY,U,2)_"-"_$S($P(APCHXY,U,4)]"":$P(APCHXY,U,4),1:"<DIAGNOSIS field missing>")
S:APCHSICF="C" APCHSICD=$P(APCHXY,U,2)
Q
GETICDOP ;ENTRY POINT
NEW APCHXY,APCHSDSC
S APCHXY=$$ICDOP^ICDEX(APCHSICD,$G(APCHCSVD),,"I")
I $P(APCHXY,U)="-1" S APCHXY=APCHSICD_U_$P($G(^ICD0(APCHSICD,0)),U,1)_U_U_$$VSTP^AUPNVUTL(APCHSICD,$G(APCHSCVD))
S APCHSDSC=$$ICDD^ICDEX($P(APCHXY,U,2),.APCHSDSC,$G(APCHCSVD))
S:APCHSICF="L" APCHSICD=$P(APCHXY,U,2)_"-"_$S($D(APCHSDSC(1)):$G(APCHSDSC(1)),1:"<DESCRIPTION field missing>")
S:APCHSICF="S" APCHSICD=$P(APCHXY,U,2)_"-"_$S($P(APCHXY,U,5)]"":$P(APCHXY,U,5),1:"<DIAGNOSIS field missing>")
S:APCHSICF="C" APCHSICD=$P(APCHXY,U,2)
Q
GETCPT ;ENTRY POINT
S Y=$$CPT^ICPTCOD(APCHSICD)
S:APCHSICF="L" APCHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
S:APCHSICF="S" APCHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
S:APCHSICF="C" APCHSICD=$P(Y,U,2)
Q
PRTICD ;ENTRY POINT
I APCHSICF="N" S:APCHSNRQ="" APCHSNRQ="<no narrative provided>" S APCHSICD=""
S APCHSTXT=$G(APCHSICD)
S:'$D(APCHSNTE) APCHSNTE=""
I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
D PRTTXT
Q
PRTICDE ;ENTRY POINT
I APCHSICF="N" S APCHSICD=""
S:'$D(APCHSNTE) APCHSNTE=""
I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE
D PRTTXT
Q
;
PRTTXT ;PEP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
S:'$D(APCHSNTE) APCHSNTE=""
S APCHSDLT=1,APCHSILN=IOM-APCHSICL-1
F APCHSQ=0:0 D PRTTXT1 Q:APCHSTXT="" D PRTTXT2
K APCHSNTE
K APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
Q
PRTTXT1 ;
S:APCHSNRQ]""&(($L(APCHSNRQ)+$L(APCHSTXT)+2)<255) APCHSTXT=$S(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ,APCHSNRQ=""
S:APCHSNTE]""&(APCHSNRQ="")&(($L(APCHSNTE)+$L(APCHSTXT)+2)<255) APCHSTXT=APCHSTXT_APCHSNTE,APCHSNTE=""
Q
PRTTXT2 D GETFRAG X APCHSCKP Q:$D(APCHSQIT) W ?APCHSICL W APCHSF,! S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0
Q
GETFRAG I $L(APCHSTXT)<APCHSILN S APCHSF=APCHSTXT,APCHSTXT="" Q
F APCHSC=APCHSILN:-1:0 Q:$E(APCHSTXT,APCHSC)=" "
S:APCHSC=0 APCHSC=APCHSILN
S APCHSF=$E(APCHSTXT,1,APCHSC-1),APCHSTXT=$E(APCHSTXT,APCHSC+1,255)
Q
;
WANTPN(T) ;EP
I '$D(^APCHSCTL(T,2)) Q 1
I $P(^APCHSCTL(T,2),U,2)="Y" Q 1
Q 0
GETNARR ;ENTRY POINT
I APCHSNRQ]"",APCHSNRQ'=0,$D(^APCHSCTL(APCHSTYP,2)),$P(^(2),U,2)="Y" S APCHSNRQ=$S($D(^AUTNPOV(APCHSNRQ)):$P(^AUTNPOV(APCHSNRQ,0),U,1),1:"***** "_APCHSNRQ_" *****")
E S APCHSNRQ=""
Q
;
;
GETSITEV ;ENTRY POINT
S APCHSP=^AUPNVSIT(APCHSVDF,0),APCHSVSC=$P(APCHSP,U,7),APCHSITE=$P(APCHSP,U,6)
GETSITE ;ENTRY POINT
S:APCHSITE="" APCHSITE="null"
S APCHSP=$G(^AUTTLOC(APCHSITE,0))
S:'$D(APCHSVDF) APCHSVDF=-1
S APCHSNFL=$P(APCHSP,U,1) S:APCHSNFL="" APCHSNFL="null" S APCHSNFL=$S($D(^DIC(4,APCHSNFL,0)):$P(^(0),U,1),$P($G(^AUPNVSIT(APCHSVDF,21)),U)]"":$P(^(21),U),1:"<"_APCHSITE_">")
S APCHSNSH=$P(APCHSP,U,2) S:$P($G(^AUPNVSIT(APCHSVDF,21)),U)]"" APCHSNSH=$E($P(^(21),U),1,12) I APCHSNSH="" S APCHSNSH="<"_APCHSITE_">"
K:APCHSVDF=-1 APCHSVDF
S APCHSNAB=$J($P(APCHSP,U,7),4) I APCHSNAB="" S APCHSNAB="<"_APCHSITE_">"
Q
;
; THE FOLLOWING CODE SEGMENTS ARE CALLED FROM 'ROUTINE"-TYPE
; MENU OPTIONS TO DISPLAY ITEMS IN A FILE
;
LC ;ENTRY POINT - FOR APCHSLST HLTH SUM COMPONENTS
S APCHSLST="^APCHSCMP(" G DSPLST
;
LS ;ENTRY POINT - FOR APCHSLST HLTH SUM TYPES
S APCHSLST="^APCHSCTL(" G DSPLST
;
LM ;ENTRY POINT - FOR APCHSLST MEASUREMENT PANEL TYPES
S APCHSLST="^APCHSMPN(" G DSPLST
;
LI ;ENTRY POINT - FOR APCHSLST HLTH SUM FLOWSHEET ITEMS
S APCHSLST="^APCHSFLI(" G DSPLST
;
LF ;ENTRY POINT - FOR APCHSLST HLTH SUM FLOWSHEETS
S APCHSLST="^APCHSFLC(" G DSPLST
;
DSPLST ; COMMON CODE FOR BUILD HLTH SUM & HLTH SUM MNX LISTS
K DIR
I '$D(@(APCHSLST_"""B"")")) W !,"NO ",$P(@(APCHSLST_"0)"),U),"S DEFINED.",! Q
W @IOF,!!,"Existing ",$P(@(APCHSLST_"0)"),U)
I $E($P(@(APCHSLST_"0)"),U),$L($P(@(APCHSLST_"0)"),U)))'="S" W "S"
W ":",! S APCHSCNT=""
CONT F S APCHSCNT=$O(@(APCHSLST_"""B"",APCHSCNT)")) Q:APCHSCNT="" W !,?5,APCHSCNT I (IOSL-3)<$Y S DIR(0)="E" D ^DIR W @IOF G:1'[Y QUIT
K DIR S DIR(0)="E" D ^DIR W !
Q
;
GENFG ;generate filegrams for export
MEASPAN ;
W !,"REMEMBER TO KILL APCHTMP BEFORE DOING THIS",!
S APCHT="MEASPAN",APCHC=0 F APCHX="ADULT STD","ADULT STD METRIC","PEDIATRIC STD","PEDIATRIC STD METRIC" S DIFGT=$O(^DIPT("B","APCH MP TYPE",0)) D
.I 'DIFGT W !,"measurement panel fg missing" Q
.S DIFG("FE")=$O(^APCHSMPN("B",APCHX,0))
.I 'DIFG("FE") W !,"panel ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
FLOW ;
G TYPE
S APCHT="FLOW",APCHC=0 F APCHX="DIABETIC FLOWSHEET" S DIFGT=$O(^DIPT("B","APCH FS TYPE",0)) D
.I 'DIFGT W !,"flowsheet fg missing" Q
.S DIFG("FE")=$O(^APCHSFLC("B",APCHX,0))
.I 'DIFG("FE") W !,"flowsheet ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
TYPE ;
S APCHT="TYPE",APCHC=0 F APCHX="ADULT REGULAR","CHR","DENTAL","DIABETES STANDARD","IMMUNIZATION","MENTAL HEALTH/SOCIAL SERVICES","PEDIATRIC","PATIENT MERGE (COMPLETE)","PROBLEM LIST" S DIFGT=$O(^DIPT("B","APCH HS TYPE",0)) D
.I 'DIFGT W !,"health summary type fg missing" Q
.S DIFG("FE")=$O(^APCHSCTL("B",APCHX,0))
.I 'DIFG("FE") W !,"type ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
K APCHC,APCHT W !,"all done"
Q
GEN1 ;
S DIFG("FUNC")="A"
S DIFG("FGR")="^APCHTMP("""_APCHT_""",APCHC,"
S DILC=0
D EN^DIFGG
I $D(DIFGER) W !,"error on ",APCHT," item ",APCHX,!
Q
QUIT K DIR,X,Y,APCHSLST,APCHSCNT
Q
APCHSUTL ; IHS/CMI/LAB - UTILITIES FOR APCHS -- SUMMARY PRODUCTION COMPONENTS
+1 ;;2.0;IHS PCC SUITE;**5,10,11**;MAY 14, 2009;Build 58
+2 ;
GETICDDX ;ENTRY POINT
+1 NEW APCHXY,APCHSDSC
+2 SET APCHXY=$$ICDDX^ICDEX(APCHSICD,$GET(APCHCSVD))
+3 IF $PIECE(APCHXY,U)="-1"
Begin DoDot:1
+4 SET APCHXY=APCHSICD_U_$PIECE($GET(^ICD9(APCHSICD,0)),U,1)_U_U_$$VSTD^AUPNVUTL(APCHSICD,$GET(APCHSCVD))
End DoDot:1
+5 SET APCHSDSC=$$ICDD^ICDEX($PIECE(APCHXY,U,2),.APCHSDSC,$GET(APCHCSVD))
+6 IF APCHSICF="L"
SET APCHSICD=$PIECE(APCHXY,U,2)_"-"_$SELECT($DATA(APCHSDSC(1)):$GET(APCHSDSC(1)),1:"<DESCRIPTION field missing>")
+7 IF APCHSICF="S"
SET APCHSICD=$PIECE(APCHXY,U,2)_"-"_$SELECT($PIECE(APCHXY,U,4)]"":$PIECE(APCHXY,U,4),1:"<DIAGNOSIS field missing>")
+8 IF APCHSICF="C"
SET APCHSICD=$PIECE(APCHXY,U,2)
+9 QUIT
GETICDOP ;ENTRY POINT
+1 NEW APCHXY,APCHSDSC
+2 SET APCHXY=$$ICDOP^ICDEX(APCHSICD,$GET(APCHCSVD),,"I")
+3 IF $PIECE(APCHXY,U)="-1"
SET APCHXY=APCHSICD_U_$PIECE($GET(^ICD0(APCHSICD,0)),U,1)_U_U_$$VSTP^AUPNVUTL(APCHSICD,$GET(APCHSCVD))
+4 SET APCHSDSC=$$ICDD^ICDEX($PIECE(APCHXY,U,2),.APCHSDSC,$GET(APCHCSVD))
+5 IF APCHSICF="L"
SET APCHSICD=$PIECE(APCHXY,U,2)_"-"_$SELECT($DATA(APCHSDSC(1)):$GET(APCHSDSC(1)),1:"<DESCRIPTION field missing>")
+6 IF APCHSICF="S"
SET APCHSICD=$PIECE(APCHXY,U,2)_"-"_$SELECT($PIECE(APCHXY,U,5)]"":$PIECE(APCHXY,U,5),1:"<DIAGNOSIS field missing>")
+7 IF APCHSICF="C"
SET APCHSICD=$PIECE(APCHXY,U,2)
+8 QUIT
GETCPT ;ENTRY POINT
+1 SET Y=$$CPT^ICPTCOD(APCHSICD)
+2 IF APCHSICF="L"
SET APCHSICD=$PIECE(Y,U,2)_"-"_$SELECT($PIECE(Y,U,3)]"":$PIECE(Y,U,3),1:"<DESCRIPTION field missing>")
+3 IF APCHSICF="S"
SET APCHSICD=$PIECE(Y,U,2)_"-"_$SELECT($PIECE(Y,U,3)]"":$PIECE(Y,U,3),1:"<DESCRIPTION field missing>")
+4 IF APCHSICF="C"
SET APCHSICD=$PIECE(Y,U,2)
+5 QUIT
PRTICD ;ENTRY POINT
+1 IF APCHSICF="N"
IF APCHSNRQ=""
SET APCHSNRQ="<no narrative provided>"
SET APCHSICD=""
+2 SET APCHSTXT=$GET(APCHSICD)
+3 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+4 IF APCHSNTE]""
SET APCHSNTE=" "_APCHSNTE
+5 DO PRTTXT
+6 QUIT
PRTICDE ;ENTRY POINT
+1 IF APCHSICF="N"
SET APCHSICD=""
+2 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+3 IF APCHSNTE]""
SET APCHSNTE=" "_APCHSNTE
+4 DO PRTTXT
+5 QUIT
+6 ;
PRTTXT ;PEP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 IF '$DATA(APCHSNTE)
SET APCHSNTE=""
+3 SET APCHSDLT=1
SET APCHSILN=IOM-APCHSICL-1
+4 FOR APCHSQ=0:0
DO PRTTXT1
IF APCHSTXT=""
QUIT
DO PRTTXT2
+5 KILL APCHSNTE
+6 KILL APCHSILN,APCHSDLT,APCHSF,APCHSC,APCHSTXT
+7 QUIT
PRTTXT1 ;
+1 IF APCHSNRQ]""&(($LENGTH(APCHSNRQ)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=$SELECT(APCHSTXT]"":APCHSTXT_"; ",1:"")_APCHSNRQ
SET APCHSNRQ=""
+2 IF APCHSNTE]""&(APCHSNRQ="")&(($LENGTH(APCHSNTE)+$LENGTH(APCHSTXT)+2)<255)
SET APCHSTXT=APCHSTXT_APCHSNTE
SET APCHSNTE=""
+3 QUIT
PRTTXT2 DO GETFRAG
XECUTE APCHSCKP
IF $DATA(APCHSQIT)
QUIT
WRITE ?APCHSICL
WRITE APCHSF,!
SET APCHSICL=APCHSICL+APCHSDLT
SET APCHSILN=APCHSILN-APCHSDLT
SET APCHSDLT=0
+1 QUIT
GETFRAG IF $LENGTH(APCHSTXT)<APCHSILN
SET APCHSF=APCHSTXT
SET APCHSTXT=""
QUIT
+1 FOR APCHSC=APCHSILN:-1:0
IF $EXTRACT(APCHSTXT,APCHSC)=" "
QUIT
+2 IF APCHSC=0
SET APCHSC=APCHSILN
+3 SET APCHSF=$EXTRACT(APCHSTXT,1,APCHSC-1)
SET APCHSTXT=$EXTRACT(APCHSTXT,APCHSC+1,255)
+4 QUIT
+5 ;
WANTPN(T) ;EP
+1 IF '$DATA(^APCHSCTL(T,2))
QUIT 1
+2 IF $PIECE(^APCHSCTL(T,2),U,2)="Y"
QUIT 1
+3 QUIT 0
GETNARR ;ENTRY POINT
+1 IF APCHSNRQ]""
IF APCHSNRQ'=0
IF $DATA(^APCHSCTL(APCHSTYP,2))
IF $PIECE(^(2),U,2)="Y"
SET APCHSNRQ=$SELECT($DATA(^AUTNPOV(APCHSNRQ)):$PIECE(^AUTNPOV(APCHSNRQ,0),U,1),1:"***** "_APCHSNRQ_" *****")
+2 IF '$TEST
SET APCHSNRQ=""
+3 QUIT
+4 ;
+5 ;
GETSITEV ;ENTRY POINT
+1 SET APCHSP=^AUPNVSIT(APCHSVDF,0)
SET APCHSVSC=$PIECE(APCHSP,U,7)
SET APCHSITE=$PIECE(APCHSP,U,6)
GETSITE ;ENTRY POINT
+1 IF APCHSITE=""
SET APCHSITE="null"
+2 SET APCHSP=$GET(^AUTTLOC(APCHSITE,0))
+3 IF '$DATA(APCHSVDF)
SET APCHSVDF=-1
+4 SET APCHSNFL=$PIECE(APCHSP,U,1)
IF APCHSNFL=""
SET APCHSNFL="null"
SET APCHSNFL=$SELECT($DATA(^DIC(4,APCHSNFL,0)):$PIECE(^(0),U,1),$PIECE($GET(^AUPNVSIT(APCHSVDF,21)),U)]"":$PIECE(^(21),U),1:"<"_APCHSITE_">")
+5 SET APCHSNSH=$PIECE(APCHSP,U,2)
IF $PIECE($GET(^AUPNVSIT(APCHSVDF,21)),U)]""
SET APCHSNSH=$EXTRACT($PIECE(^(21),U),1,12)
IF APCHSNSH=""
SET APCHSNSH="<"_APCHSITE_">"
+6 IF APCHSVDF=-1
KILL APCHSVDF
+7 SET APCHSNAB=$JUSTIFY($PIECE(APCHSP,U,7),4)
IF APCHSNAB=""
SET APCHSNAB="<"_APCHSITE_">"
+8 QUIT
+9 ;
+10 ; THE FOLLOWING CODE SEGMENTS ARE CALLED FROM 'ROUTINE"-TYPE
+11 ; MENU OPTIONS TO DISPLAY ITEMS IN A FILE
+12 ;
LC ;ENTRY POINT - FOR APCHSLST HLTH SUM COMPONENTS
+1 SET APCHSLST="^APCHSCMP("
GOTO DSPLST
+2 ;
LS ;ENTRY POINT - FOR APCHSLST HLTH SUM TYPES
+1 SET APCHSLST="^APCHSCTL("
GOTO DSPLST
+2 ;
LM ;ENTRY POINT - FOR APCHSLST MEASUREMENT PANEL TYPES
+1 SET APCHSLST="^APCHSMPN("
GOTO DSPLST
+2 ;
LI ;ENTRY POINT - FOR APCHSLST HLTH SUM FLOWSHEET ITEMS
+1 SET APCHSLST="^APCHSFLI("
GOTO DSPLST
+2 ;
LF ;ENTRY POINT - FOR APCHSLST HLTH SUM FLOWSHEETS
+1 SET APCHSLST="^APCHSFLC("
GOTO DSPLST
+2 ;
DSPLST ; COMMON CODE FOR BUILD HLTH SUM & HLTH SUM MNX LISTS
+1 KILL DIR
+2 IF '$DATA(@(APCHSLST_"""B"")"))
WRITE !,"NO ",$PIECE(@(APCHSLST_"0)"),U),"S DEFINED.",!
QUIT
+3 WRITE @IOF,!!,"Existing ",$PIECE(@(APCHSLST_"0)"),U)
+4 IF $EXTRACT($PIECE(@(APCHSLST_"0)"),U),$LENGTH($PIECE(@(APCHSLST_"0)"),U)))'="S"
WRITE "S"
+5 WRITE ":",!
SET APCHSCNT=""
CONT FOR
SET APCHSCNT=$ORDER(@(APCHSLST_"""B"",APCHSCNT)"))
IF APCHSCNT=""
QUIT
WRITE !,?5,APCHSCNT
IF (IOSL-3)<$Y
SET DIR(0)="E"
DO ^DIR
WRITE @IOF
IF 1'[Y
GOTO QUIT
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
WRITE !
+2 QUIT
+3 ;
GENFG ;generate filegrams for export
MEASPAN ;
+1 WRITE !,"REMEMBER TO KILL APCHTMP BEFORE DOING THIS",!
+2 SET APCHT="MEASPAN"
SET APCHC=0
FOR APCHX="ADULT STD","ADULT STD METRIC","PEDIATRIC STD","PEDIATRIC STD METRIC"
SET DIFGT=$ORDER(^DIPT("B","APCH MP TYPE",0))
Begin DoDot:1
+3 IF 'DIFGT
WRITE !,"measurement panel fg missing"
QUIT
+4 SET DIFG("FE")=$ORDER(^APCHSMPN("B",APCHX,0))
+5 IF 'DIFG("FE")
WRITE !,"panel ",APCHX," missing.",!
QUIT
+6 SET APCHC=APCHC+1
+7 DO GEN1
+8 QUIT
End DoDot:1
FLOW ;
+1 GOTO TYPE
+2 SET APCHT="FLOW"
SET APCHC=0
FOR APCHX="DIABETIC FLOWSHEET"
SET DIFGT=$ORDER(^DIPT("B","APCH FS TYPE",0))
Begin DoDot:1
+3 IF 'DIFGT
WRITE !,"flowsheet fg missing"
QUIT
+4 SET DIFG("FE")=$ORDER(^APCHSFLC("B",APCHX,0))
+5 IF 'DIFG("FE")
WRITE !,"flowsheet ",APCHX," missing.",!
QUIT
+6 SET APCHC=APCHC+1
+7 DO GEN1
+8 QUIT
End DoDot:1
TYPE ;
+1 SET APCHT="TYPE"
SET APCHC=0
FOR APCHX="ADULT REGULAR","CHR","DENTAL","DIABETES STANDARD","IMMUNIZATION","MENTAL HEALTH/SOCIAL SERVICES","PEDIATRIC","PATIENT MERGE (COMPLETE)","PROBLEM LIST"
SET DIFGT=$ORDER(^DIPT("B","APCH HS TYPE",0))
Begin DoDot:1
+2 IF 'DIFGT
WRITE !,"health summary type fg missing"
QUIT
+3 SET DIFG("FE")=$ORDER(^APCHSCTL("B",APCHX,0))
+4 IF 'DIFG("FE")
WRITE !,"type ",APCHX," missing.",!
QUIT
+5 SET APCHC=APCHC+1
+6 DO GEN1
+7 QUIT
End DoDot:1
+8 KILL APCHC,APCHT
WRITE !,"all done"
+9 QUIT
GEN1 ;
+1 SET DIFG("FUNC")="A"
+2 SET DIFG("FGR")="^APCHTMP("""_APCHT_""",APCHC,"
+3 SET DILC=0
+4 DO EN^DIFGG
+5 IF $DATA(DIFGER)
WRITE !,"error on ",APCHT," item ",APCHX,!
+6 QUIT
QUIT KILL DIR,X,Y,APCHSLST,APCHSCNT
+1 QUIT
