ACMRGA02.m

ACMRGA02 ; IHS/TUCSON/TMJ - CREATES PRE-DIABETES REGISTER AT RUN TIME ; [ 09/19/05  1:18 PM ]

 ;;2.0;ACM CASE MANAGEMENT SYSTEM;*6*;JAN 10, 1996

 ;ROUTINE TO CREATE A REGISTER CALLED FROM ACMADDP

 ;IHS PRE-DIABETES REGISTER 8/22/05

 Q

 ;

REG ;EP;CHECKS AND CREATES REGISTER

 S ACMRG=$T(NAME+1),ACMRG=$P(ACMRG,";;",3) W !,ACMRG I $L(ACMRG),$D(^ACM(41.1,"B",ACMRG)) W !!,"Register:  ",ACMRG," already exists...quiting",!! Q

 W !!,"Register:  ",ACMRG," is being added...",!!

 S X=ACMRG,DIC="^ACM(41.1,",DIC(0)="LX" K DD,DA D FILE^DICN Q:+Y<1  S ACMRG=+Y K DIC,DA,DD,DR,DINUM,D

 F I=2:1 S ACMF=$T(NAME+I) Q:ACMF["*"  S ACMF($P(ACMF,";;",2))=$P(ACMF,";;",3)

 S ACMX=0 F  S ACMX=$O(ACMF(ACMX)) Q:ACMX=""  S ACMY=0,ACMY=$O(^DD(9002241.1,"B",ACMX,ACMY)) I +ACMY S $P(ACMF(ACMX),U,2)=+ACMY

 S DR="" S ACMX="" F  S ACMX=$O(ACMF(ACMX)) Q:ACMX=""  S ACMY=ACMF(ACMX) I $L($P(ACMY,U,1))&(+$P(ACMY,U,2)) S DR=DR_$P(ACMY,U,2)_"///"_$P(ACMY,U,1)_";"

 I $L(DR) S DR=$E(DR,1,$L(DR)-1)

 S DA=ACMRG,DIE="^ACM(41.1," D ^DIE S $P(^ACM(41.1,ACMRG,0),U,12)=1 K DIC,DIE,DA,DR

ADDS ;ADDS ELEMENTS,DIAG,COMPL, DX CRITERIA, RISK FACTORS ETC TO REGISTER

 D SETE,SETD,SETC,SETR,SETDC W "...FINISHED...",!!

 K ACMX,ACMEX,ACXE,ACZ,ACMCX,ACMDX,ACMRF,ACMDC

 Q

 ;

SETE ;EP;ADDS ELEMENTS TO NEW REGISTER     

 K ACME F I=1:1 S ACME=$T(ELEM+I) Q:ACME["*"  S ACME($P(ACME,";;",3))=$P(ACME,";;",3)

 W !,"adding elements..." S ACMEX="" F  S ACMEX=$O(ACME(ACMEX)) Q:ACMEX=""  K ACMY D SETE0 I $D(ACMY) D SETE1

 Q

SETE0 S:$D(^ACM(56,"B",ACMEX)) ACMY=1 W "." Q

SETE1 S ACMY=0,ACMY=$O(^ACM(56,"B",ACMEX,ACMY)) S (DA,X,DINUM)=ACMY,DA(1)=ACMRG

 K DIC,DD S (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,",DIC(0)="L"

 S:'$D(^ACM(41.1,ACMRG,2,0)) ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"

 K DD,DO D FILE^DICN K DIC,DD,DR

 Q

 ;

SETD ;EP;ADDS DIAGNOSIS TO NEW REGISTER     

 W !,"adding diagnosis...." K ACME S ACME="" F I=1:1 S ACME=$T(DIAG+I) Q:ACME["*"  S ACME($P(ACME,";;",3))=$P(ACME,";;",3)

 S ACMDX="" F  S ACMDX=$O(ACME(ACMDX)) Q:ACMDX=""  D SETD0

 Q

SETD0 I $D(^ACM(44.1,"B",ACMDX)) S ACMY=0,ACMY=$O(^ACM(44.1,"B",ACMDX,ACMY)) W "." G SETD1

 K DIC,DD,DO S (DIE,DIC)="^ACM(44.1,",DIC(0)="L",X=ACMDX D FILE^DICN S ACMY=+Y

SETD1 S X=ACMRG,DA(1)=ACMY

 K DIC,DD S (DIE,DIC)="^ACM(44.1,"_ACMY_",""RG"",",DIC(0)="L"

 S:'$D(^ACM(44.1,ACMY,"RG",0)) ^ACM(44.1,ACMY,"RG",0)="^9002244.11P^^"

 I $D(^ACM(44.1,ACMY,"RG","B",ACMRG)) Q

 K DD,DO D FILE^DICN K DIC,DD,DR

 Q

 ;

SETC ;EP;ADDS COMPLICATIONS TO NEW REGISTER     

 W !,"adding complications....." K ACME S ACME="" F I=1:1 S ACME=$T(COMP+I) Q:ACME["*"  S ACME($P(ACME,";;",3))=$P(ACME,";;",3)

 S ACMCX="" F  S ACMCX=$O(ACME(ACMCX)) Q:ACMCX=""  D SETC0

 Q

SETC0 I $D(^ACM(42.1,"B",ACMCX)) S ACMY=0,ACMY=$O(^ACM(42.1,"B",ACMCX,ACMY)) W "." G SETC1

 K DIC,DD,DO S (DIE,DIC)="^ACM(42.1,",DIC(0)="L",X=ACMCX D FILE^DICN S ACMY=+Y

SETC1 S X=ACMRG,DA(1)=ACMY

 K DIC,DD S (DIE,DIC)="^ACM(42.1,"_ACMY_",""RG"",",DIC(0)="L"

 S:'$D(^ACM(42.1,ACMY,"RG",0)) ^ACM(42.1,ACMY,"RG",0)="^9002242.11P^^"

 I $D(^ACM(42.1,ACMY,"RG","B",ACMRG)) Q

 K DD,DO D FILE^DICN K DIC,DD,DR

 Q

 ;

NAME ;;

 ;;REGISTER TYPE;;IHS PRE-DIABETES;;.01

 ;;ABBREVIATION;;DM;;.02

 ;;AUTHORIZED USER;;

 ;;DATE ESTABLISHED;;T

 ;;DATE LAST MODIFIED;;

 ;;REGISTER DEVELOPER;;POSTMASTER

 ;;DEVELOPER PHONE;;

 ;;CONFIDENTIAL REGISTER;;YES

 ;;VIEW ALL LIST ENTRIES;;NO

 ;;ALLOW LAYGO FOR LIST ENTRIES;;NO

 ;;DESCRIPTION;;

 ;;LETTER ADDRESS STARTING LINE;;

 ;;LETTER ADDRESS STARTING COLUMN;;

 ;;PHONE NUMBER;;

 ;;LETTER SIGNATURE;;

 ;;LETTER HEAD LINE 1;;

 ;;LETTER HEAD LINE 2;;

 ;;PCC PROBLEM LIST;;YES

 ;;*

 ;;BRIEF DESCRIPTION;;IHS National Pre-Diabetes Register

 ;;*

ELEM ;;

 ;;ELEMENTS;;COMPLICATIONS

 ;;ELEMENTS;;DIAGNOSES

 ;;ELEMENTS;;RISK FACTORS

 ;;ELEMENTS;;DIAGNOSTIC CRITERIA

 ;;ELEMENTS;;REGISTER DATA

 ;;ELEMENTS;;CASE REVIEW DATES

 ;;*

COMP ;;

 ;;COMPLICATIONS;;HYPERLIPIDEMIA

 ;;COMPLICATIONS;;OBESITY - NOS

 ;;COMPLICATIONS;;MORBID OBESITY

 ;;COMPLICATIONS;;HYPERTENSION

 ;;COMPLICATIONS;;POLYCYSTIC OVARIES

 ;;COMPLICATIONS;;PROTEINURIA

 ;;COMPLICATIONS;;ACQUIRED ACANTHOSIS NIGRICANS

 ;;*

DIAG ;;

 ;;DIAGNOSIS;;IMP FASTING GLUCOSE (IFG)

 ;;DIAGNOSIS;;IMP GLUCOSE TOLERANCE (IGT)

 ;;DIAGNOSIS;;OTHER ABNORMAL GLUCOSE

 ;;DIAGNOSIS;;METABOLIC SYNDROME

 ;;*

RISK ;;

 ;;RISK FACTORS;;BMI > 25

 ;;RISK FACTORS;;HX OF GESTATIONAL DIABETES

 ;;RISK FACTORS;;POLYCYSTIC OVARY DISEASE

 ;;RISK FACTORS;;FAMILY HX - TYPE 2 DIABETES

 ;;RISK FACTORS;;MOTHER - GESTATIONAL DIABETES

 ;;*

DXCRIT ;;

 ;;DIAGNOSTIC CRITERIA;;WAIST CIRCUM >40 (MEN)

 ;;DIAGNOSTIC CRITERIA;;WAIST CIRCUM >35 (WOMEN)

 ;;DIAGNOSTIC CRITERIA;;BMI > 30

 ;;DIAGNOSTIC CRITERIA;;TG > 150 mg/dl

 ;;DIAGNOSTIC CRITERIA;;HDL < 40 mg/dl (MEN)

 ;;DIAGNOSTIC CRITERIA;;HDL < 50 (WOMEN)

 ;;DIAGNOSTIC CRITERIA;;BP > 130/85 mm Hg

 ;;DIAGNOSTIC CRITERIA;;FPG > 100 mg/dl

 ;;*

GDIAG S ACMX="" F I=1:1 S ACMX=$T(DIAG+I) Q:ACXE["*"  S ACME("SET",$P(ACMX,";;",3))=$P(ACMX,";;",3)

 Q

 ;

SETR ;EP;ADDS RISK FACTORS TO NEW REGISTER

 W !,"adding Risk Factors...." K ACME S ACME="" F I=1:1 S ACME=$T(RISK+I) Q:ACME["*"  S ACME($P(ACME,";;",3))=$P(ACME,";;",3)

 S ACMRF="" F  S ACMRF=$O(ACME(ACMRF)) Q:ACMRF=""  D SETR0

 Q

 ;

SETR0 I $D(^ACM(45.1,"B",ACMRF)) S ACMY=0,ACMY=$O(^ACM(45.1,"B",ACMRF,ACMY)) W "." G SETR1

 K DIC,DD,D0 S (DIE,DIC)="^ACM(45.1,",DIC(0)="L",X=ACMRF D FILE^DICN S ACMY=+Y

SETR1 S X=ACMRG,DA(1)=ACMY

 K DIC,DD S (DIE,DIC)="^ACM(45.1,"_ACMY_",""RG"",",DIC(0)="L"

 S:'$D(^ACM(45.1,ACMY,"RG",0)) ^ACM(45.1,ACMY,"RG",0)="^9002245.11P^^"

 I $D(^ACM(45.1,ACMY,"RG","B",ACMRG)) Q

 K DD,DO D FILE^DICN K DIC,DD,DR

 Q

 ;

SETDC ;EP;ADDS DIAGNOSTIC CRITERIA TO NEW REGISTER

 W !,"adding Diagnostic Criteria...." K ACME S ACME="" F I=1:1 S ACME=$T(DXCRIT+I) Q:ACME["*"  S ACME($P(ACME,";;",3))=$P(ACME,";;",3)

 S ACMDC="" F  S ACMDC=$O(ACME(ACMDC)) Q:ACMDC=""  D SETDC0

 ;

 Q

SETDC0 I $D(^ACM(51.1,"B",ACMDC)) S ACMY=0,ACMY=$O(^ACM(51.1,"B",ACMDC,ACMY)) W "." G SETDC1

 K DIC,DD,D0 S (DIE,DIC)="^ACM(51.1,",DIC(0)="L",X=ACMDC D FILE^DICN S ACMY=+Y

 ;

SETDC1 S X=ACMRG,DA(1)=ACMY

 K DIC,DD S (DIE,DIC)="^ACM(51.1,"_ACMY_",""RG"",",DIC(0)="L"

 S:'$D(^ACM(51.1,ACMY,"RG",0)) ^ACM(51.1,ACMY,"RG",0)="^9002251.12P^^"

 I $D(^ACM(51.1,ACMY,"RG","B",ACMRG)) Q

 K DD,DO D FILE^DICN K DIC,DD,DR

 Q

 ;

ACMRGA02  ; IHS/TUCSON/TMJ - CREATES PRE-DIABETES REGISTER AT RUN TIME ; [ 09/19/05  1:18 PM ]

 +1       ;;2.0;ACM CASE MANAGEMENT SYSTEM;*6*;JAN 10, 1996

 +2       ;ROUTINE TO CREATE A REGISTER CALLED FROM ACMADDP

 +3       ;IHS PRE-DIABETES REGISTER 8/22/05

 +4        QUIT 

 +5       ;

REG       ;EP;CHECKS AND CREATES REGISTER

 +1        SET ACMRG=$TEXT(NAME+1)

           SET ACMRG=$PIECE(ACMRG,";;",3)

           WRITE !,ACMRG

           IF $LENGTH(ACMRG)

               IF $DATA(^ACM(41.1,"B",ACMRG))

                   WRITE !!,"Register:  ",ACMRG," already exists...quiting",!!

                   QUIT 

 +2        WRITE !!,"Register:  ",ACMRG," is being added...",!!

 +3        SET X=ACMRG

           SET DIC="^ACM(41.1,"

           SET DIC(0)="LX"

           KILL DD,DA

           DO FILE^DICN

           IF +Y<1

               QUIT 

           SET ACMRG=+Y

           KILL DIC,DA,DD,DR,DINUM,D

 +4        FOR I=2:1

               SET ACMF=$TEXT(NAME+I)

               IF ACMF["*"

                   QUIT 

               SET ACMF($PIECE(ACMF,";;",2))=$PIECE(ACMF,";;",3)

 +5        SET ACMX=0

           FOR 

               SET ACMX=$ORDER(ACMF(ACMX))

               IF ACMX=""

                   QUIT 

               SET ACMY=0

               SET ACMY=$ORDER(^DD(9002241.1,"B",ACMX,ACMY))

               IF +ACMY

                   SET $PIECE(ACMF(ACMX),U,2)=+ACMY

 +6        SET DR=""

           SET ACMX=""

           FOR 

               SET ACMX=$ORDER(ACMF(ACMX))

               IF ACMX=""

                   QUIT 

               SET ACMY=ACMF(ACMX)

               IF $LENGTH($PIECE(ACMY,U,1))&(+$PIECE(ACMY,U,2))

                   SET DR=DR_$PIECE(ACMY,U,2)_"///"_$PIECE(ACMY,U,1)_";"

 +7        IF $LENGTH(DR)

               SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)

 +8        SET DA=ACMRG

           SET DIE="^ACM(41.1,"

           DO ^DIE

           SET $PIECE(^ACM(41.1,ACMRG,0),U,12)=1

           KILL DIC,DIE,DA,DR

ADDS      ;ADDS ELEMENTS,DIAG,COMPL, DX CRITERIA, RISK FACTORS ETC TO REGISTER

 +1        DO SETE

           DO SETD

           DO SETC

           DO SETR

           DO SETDC

           WRITE "...FINISHED...",!!

 +2        KILL ACMX,ACMEX,ACXE,ACZ,ACMCX,ACMDX,ACMRF,ACMDC

 +3        QUIT 

 +4       ;

SETE      ;EP;ADDS ELEMENTS TO NEW REGISTER     

 +1        KILL ACME

           FOR I=1:1

               SET ACME=$TEXT(ELEM+I)

               IF ACME["*"

                   QUIT 

               SET ACME($PIECE(ACME,";;",3))=$PIECE(ACME,";;",3)

 +2        WRITE !,"adding elements..."

           SET ACMEX=""

           FOR 

               SET ACMEX=$ORDER(ACME(ACMEX))

               IF ACMEX=""

                   QUIT 

               KILL ACMY

               DO SETE0

               IF $DATA(ACMY)

                   DO SETE1

 +3        QUIT 

SETE0      IF $DATA(^ACM(56,"B",ACMEX))

               SET ACMY=1

           WRITE "."

           QUIT 

SETE1      SET ACMY=0

           SET ACMY=$ORDER(^ACM(56,"B",ACMEX,ACMY))

           SET (DA,X,DINUM)=ACMY

           SET DA(1)=ACMRG

 +1        KILL DIC,DD

           SET (DIE,DIC)="^ACM(41.1,"_ACMRG_",2,"

           SET DIC(0)="L"

 +2        IF '$DATA(^ACM(41.1,ACMRG,2,0))

               SET ^ACM(41.1,ACMRG,2,0)="^9002241.13P^^"

 +3        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DD,DR

 +4        QUIT 

 +5       ;

SETD      ;EP;ADDS DIAGNOSIS TO NEW REGISTER     

 +1        WRITE !,"adding diagnosis...."

           KILL ACME

           SET ACME=""

           FOR I=1:1

               SET ACME=$TEXT(DIAG+I)

               IF ACME["*"

                   QUIT 

               SET ACME($PIECE(ACME,";;",3))=$PIECE(ACME,";;",3)

 +2        SET ACMDX=""

           FOR 

               SET ACMDX=$ORDER(ACME(ACMDX))

               IF ACMDX=""

                   QUIT 

               DO SETD0

 +3        QUIT 

SETD0      IF $DATA(^ACM(44.1,"B",ACMDX))

               SET ACMY=0

               SET ACMY=$ORDER(^ACM(44.1,"B",ACMDX,ACMY))

               WRITE "."

               GOTO SETD1

 +1        KILL DIC,DD,DO

           SET (DIE,DIC)="^ACM(44.1,"

           SET DIC(0)="L"

           SET X=ACMDX

           DO FILE^DICN

           SET ACMY=+Y

SETD1      SET X=ACMRG

           SET DA(1)=ACMY

 +1        KILL DIC,DD

           SET (DIE,DIC)="^ACM(44.1,"_ACMY_",""RG"","

           SET DIC(0)="L"

 +2        IF '$DATA(^ACM(44.1,ACMY,"RG",0))

               SET ^ACM(44.1,ACMY,"RG",0)="^9002244.11P^^"

 +3        IF $DATA(^ACM(44.1,ACMY,"RG","B",ACMRG))

               QUIT 

 +4        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DD,DR

 +5        QUIT 

 +6       ;

SETC      ;EP;ADDS COMPLICATIONS TO NEW REGISTER     

 +1        WRITE !,"adding complications....."

           KILL ACME

           SET ACME=""

           FOR I=1:1

               SET ACME=$TEXT(COMP+I)

               IF ACME["*"

                   QUIT 

               SET ACME($PIECE(ACME,";;",3))=$PIECE(ACME,";;",3)

 +2        SET ACMCX=""

           FOR 

               SET ACMCX=$ORDER(ACME(ACMCX))

               IF ACMCX=""

                   QUIT 

               DO SETC0

 +3        QUIT 

SETC0      IF $DATA(^ACM(42.1,"B",ACMCX))

               SET ACMY=0

               SET ACMY=$ORDER(^ACM(42.1,"B",ACMCX,ACMY))

               WRITE "."

               GOTO SETC1

 +1        KILL DIC,DD,DO

           SET (DIE,DIC)="^ACM(42.1,"

           SET DIC(0)="L"

           SET X=ACMCX

           DO FILE^DICN

           SET ACMY=+Y

SETC1      SET X=ACMRG

           SET DA(1)=ACMY

 +1        KILL DIC,DD

           SET (DIE,DIC)="^ACM(42.1,"_ACMY_",""RG"","

           SET DIC(0)="L"

 +2        IF '$DATA(^ACM(42.1,ACMY,"RG",0))

               SET ^ACM(42.1,ACMY,"RG",0)="^9002242.11P^^"

 +3        IF $DATA(^ACM(42.1,ACMY,"RG","B",ACMRG))

               QUIT 

 +4        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DD,DR

 +5        QUIT 

 +6       ;

NAME      ;;

 +1       ;;REGISTER TYPE;;IHS PRE-DIABETES;;.01

 +2       ;;ABBREVIATION;;DM;;.02

 +3       ;;AUTHORIZED USER;;

 +4       ;;DATE ESTABLISHED;;T

 +5       ;;DATE LAST MODIFIED;;

 +6       ;;REGISTER DEVELOPER;;POSTMASTER

 +7       ;;DEVELOPER PHONE;;

 +8       ;;CONFIDENTIAL REGISTER;;YES

 +9       ;;VIEW ALL LIST ENTRIES;;NO

 +10      ;;ALLOW LAYGO FOR LIST ENTRIES;;NO

 +11      ;;DESCRIPTION;;

 +12      ;;LETTER ADDRESS STARTING LINE;;

 +13      ;;LETTER ADDRESS STARTING COLUMN;;

 +14      ;;PHONE NUMBER;;

 +15      ;;LETTER SIGNATURE;;

 +16      ;;LETTER HEAD LINE 1;;

 +17      ;;LETTER HEAD LINE 2;;

 +18      ;;PCC PROBLEM LIST;;YES

 +19      ;;*

 +20      ;;BRIEF DESCRIPTION;;IHS National Pre-Diabetes Register

 +21      ;;*

ELEM      ;;

 +1       ;;ELEMENTS;;COMPLICATIONS

 +2       ;;ELEMENTS;;DIAGNOSES

 +3       ;;ELEMENTS;;RISK FACTORS

 +4       ;;ELEMENTS;;DIAGNOSTIC CRITERIA

 +5       ;;ELEMENTS;;REGISTER DATA

 +6       ;;ELEMENTS;;CASE REVIEW DATES

 +7       ;;*

COMP      ;;

 +1       ;;COMPLICATIONS;;HYPERLIPIDEMIA

 +2       ;;COMPLICATIONS;;OBESITY - NOS

 +3       ;;COMPLICATIONS;;MORBID OBESITY

 +4       ;;COMPLICATIONS;;HYPERTENSION

 +5       ;;COMPLICATIONS;;POLYCYSTIC OVARIES

 +6       ;;COMPLICATIONS;;PROTEINURIA

 +7       ;;COMPLICATIONS;;ACQUIRED ACANTHOSIS NIGRICANS

 +8       ;;*

DIAG      ;;

 +1       ;;DIAGNOSIS;;IMP FASTING GLUCOSE (IFG)

 +2       ;;DIAGNOSIS;;IMP GLUCOSE TOLERANCE (IGT)

 +3       ;;DIAGNOSIS;;OTHER ABNORMAL GLUCOSE

 +4       ;;DIAGNOSIS;;METABOLIC SYNDROME

 +5       ;;*

RISK      ;;

 +1       ;;RISK FACTORS;;BMI > 25

 +2       ;;RISK FACTORS;;HX OF GESTATIONAL DIABETES

 +3       ;;RISK FACTORS;;POLYCYSTIC OVARY DISEASE

 +4       ;;RISK FACTORS;;FAMILY HX - TYPE 2 DIABETES

 +5       ;;RISK FACTORS;;MOTHER - GESTATIONAL DIABETES

 +6       ;;*

DXCRIT    ;;

 +1       ;;DIAGNOSTIC CRITERIA;;WAIST CIRCUM >40 (MEN)

 +2       ;;DIAGNOSTIC CRITERIA;;WAIST CIRCUM >35 (WOMEN)

 +3       ;;DIAGNOSTIC CRITERIA;;BMI > 30

 +4       ;;DIAGNOSTIC CRITERIA;;TG > 150 mg/dl

 +5       ;;DIAGNOSTIC CRITERIA;;HDL < 40 mg/dl (MEN)

 +6       ;;DIAGNOSTIC CRITERIA;;HDL < 50 (WOMEN)

 +7       ;;DIAGNOSTIC CRITERIA;;BP > 130/85 mm Hg

 +8       ;;DIAGNOSTIC CRITERIA;;FPG > 100 mg/dl

 +9       ;;*

GDIAG      SET ACMX=""

           FOR I=1:1

               SET ACMX=$TEXT(DIAG+I)

               IF ACXE["*"

                   QUIT 

               SET ACME("SET",$PIECE(ACMX,";;",3))=$PIECE(ACMX,";;",3)

 +1        QUIT 

 +2       ;

SETR      ;EP;ADDS RISK FACTORS TO NEW REGISTER

 +1        WRITE !,"adding Risk Factors...."

           KILL ACME

           SET ACME=""

           FOR I=1:1

               SET ACME=$TEXT(RISK+I)

               IF ACME["*"

                   QUIT 

               SET ACME($PIECE(ACME,";;",3))=$PIECE(ACME,";;",3)

 +2        SET ACMRF=""

           FOR 

               SET ACMRF=$ORDER(ACME(ACMRF))

               IF ACMRF=""

                   QUIT 

               DO SETR0

 +3        QUIT 

 +4       ;

SETR0      IF $DATA(^ACM(45.1,"B",ACMRF))

               SET ACMY=0

               SET ACMY=$ORDER(^ACM(45.1,"B",ACMRF,ACMY))

               WRITE "."

               GOTO SETR1

 +1        KILL DIC,DD,D0

           SET (DIE,DIC)="^ACM(45.1,"

           SET DIC(0)="L"

           SET X=ACMRF

           DO FILE^DICN

           SET ACMY=+Y

SETR1      SET X=ACMRG

           SET DA(1)=ACMY

 +1        KILL DIC,DD

           SET (DIE,DIC)="^ACM(45.1,"_ACMY_",""RG"","

           SET DIC(0)="L"

 +2        IF '$DATA(^ACM(45.1,ACMY,"RG",0))

               SET ^ACM(45.1,ACMY,"RG",0)="^9002245.11P^^"

 +3        IF $DATA(^ACM(45.1,ACMY,"RG","B",ACMRG))

               QUIT 

 +4        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DD,DR

 +5        QUIT 

 +6       ;

SETDC     ;EP;ADDS DIAGNOSTIC CRITERIA TO NEW REGISTER

 +1        WRITE !,"adding Diagnostic Criteria...."

           KILL ACME

           SET ACME=""

           FOR I=1:1

               SET ACME=$TEXT(DXCRIT+I)

               IF ACME["*"

                   QUIT 

               SET ACME($PIECE(ACME,";;",3))=$PIECE(ACME,";;",3)

 +2        SET ACMDC=""

           FOR 

               SET ACMDC=$ORDER(ACME(ACMDC))

               IF ACMDC=""

                   QUIT 

               DO SETDC0

 +3       ;

 +4        QUIT 

SETDC0     IF $DATA(^ACM(51.1,"B",ACMDC))

               SET ACMY=0

               SET ACMY=$ORDER(^ACM(51.1,"B",ACMDC,ACMY))

               WRITE "."

               GOTO SETDC1

 +1        KILL DIC,DD,D0

           SET (DIE,DIC)="^ACM(51.1,"

           SET DIC(0)="L"

           SET X=ACMDC

           DO FILE^DICN

           SET ACMY=+Y

 +2       ;

SETDC1     SET X=ACMRG

           SET DA(1)=ACMY

 +1        KILL DIC,DD

           SET (DIE,DIC)="^ACM(51.1,"_ACMY_",""RG"","

           SET DIC(0)="L"

 +2        IF '$DATA(^ACM(51.1,ACMY,"RG",0))

               SET ^ACM(51.1,ACMY,"RG",0)="^9002251.12P^^"

 +3        IF $DATA(^ACM(51.1,ACMY,"RG","B",ACMRG))

               QUIT 

 +4        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DD,DR

 +5        QUIT 

 +6       ;