Routine: APCHSUTL

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)

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)

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)

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

PRTICDE ;ENTRY POINT

 I APCHSICF="N" S APCHSICD=""

 S:'$D(APCHSNTE) APCHSNTE=""

 I APCHSNTE]"" S APCHSNTE=" "_APCHSNTE

 D PRTTXT

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

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=""

PRTTXT2 D GETFRAG X APCHSCKP Q:$D(APCHSQIT)  W ?APCHSICL W APCHSF,! S APCHSICL=APCHSICL+APCHSDLT,APCHSILN=APCHSILN-APCHSDLT,APCHSDLT=0

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)

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=""

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_">"

 ; 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 !

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"

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,!

QUIT K DIR,X,Y,APCHSLST,APCHSCNT

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

APCHSUTL.m