ACMRGA01.m

ACMRGA01 ; IHS/TUCSON/TMJ - CREATES REGISTER AT RUN TIME ;

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

 ;ROUTINE TO CREATE A REGISTER CALLED FROM ACMADDM

 ;IHS DIABETES REGISTER 10/7/93

 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 ETC TO REGISTER

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

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

 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 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 Diabetes Register

 ;;*

ELEM ;;

 ;;ELEMENTS;;COMPLICATIONS

 ;;ELEMENTS;;DIAGNOSES

 ;;ELEMENTS;;FAMILY MEMBERS

 ;;ELEMENTS;;PCC PROBLEM LIST

 ;;ELEMENTS;;REGISTER DATA

 ;;*

COMP ;;

 ;;COMPLICATIONS;;CVA (STROKE)

 ;;COMPLICATIONS;;END STAGE RENAL DISEASE

 ;;COMPLICATIONS;;HIGH RISK FOOT

 ;;COMPLICATIONS;;HYPERTENSION

 ;;COMPLICATIONS;;FIXED PROTEINURIA

 ;;COMPLICATIONS;;LASER TX FOR RETINOPATHY

 ;;COMPLICATIONS;;MAJOR AMPUTATION(S)

 ;;COMPLICATIONS;;MINOR AMPUTATION(S)

 ;;COMPLICATIONS;;MYOCARDIAL INFARCTION

 ;;COMPLICATIONS;;RETINOPATHY

 ;;*

DIAG ;;

 ;;DIAGNOSIS;;GESTATIONAL DM

 ;;DIAGNOSIS;;IDDM

 ;;DIAGNOSIS;;IMPAIRED GLUCOSE TOLERANCE

 ;;DIAGNOSIS;;NIDDM

 ;;*

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

 Q

ACMRGA01  ; IHS/TUCSON/TMJ - CREATES REGISTER AT RUN TIME ;

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

 +2       ;ROUTINE TO CREATE A REGISTER CALLED FROM ACMADDM

 +3       ;IHS DIABETES REGISTER 10/7/93

 +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 ETC TO REGISTER

 +1        DO SETE

           DO SETD

           DO SETC

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

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

 +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 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 Diabetes Register

 +21      ;;*

ELEM      ;;

 +1       ;;ELEMENTS;;COMPLICATIONS

 +2       ;;ELEMENTS;;DIAGNOSES

 +3       ;;ELEMENTS;;FAMILY MEMBERS

 +4       ;;ELEMENTS;;PCC PROBLEM LIST

 +5       ;;ELEMENTS;;REGISTER DATA

 +6       ;;*

COMP      ;;

 +1       ;;COMPLICATIONS;;CVA (STROKE)

 +2       ;;COMPLICATIONS;;END STAGE RENAL DISEASE

 +3       ;;COMPLICATIONS;;HIGH RISK FOOT

 +4       ;;COMPLICATIONS;;HYPERTENSION

 +5       ;;COMPLICATIONS;;FIXED PROTEINURIA

 +6       ;;COMPLICATIONS;;LASER TX FOR RETINOPATHY

 +7       ;;COMPLICATIONS;;MAJOR AMPUTATION(S)

 +8       ;;COMPLICATIONS;;MINOR AMPUTATION(S)

 +9       ;;COMPLICATIONS;;MYOCARDIAL INFARCTION

 +10      ;;COMPLICATIONS;;RETINOPATHY

 +11      ;;*

DIAG      ;;

 +1       ;;DIAGNOSIS;;GESTATIONAL DM

 +2       ;;DIAGNOSIS;;IDDM

 +3       ;;DIAGNOSIS;;IMPAIRED GLUCOSE TOLERANCE

 +4       ;;DIAGNOSIS;;NIDDM

 +5       ;;*

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