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
