BDMFUTIL ; IHS/CMI/LAB - DMS UTILITY PROGRAM ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8**;JUN 14, 2007;Build 53
;UTILITY PROGRAM
;LOCATION FOR VARIOUS UTILITY FUNCTIONS
TAX ;EP;TAXONOMY MANAGEMENT
F D TAX1 Q:$D(BDMQUIT)!$D(BDMOUT)
TAXEXIT K BDMQUIT,BDMOUT
Q
TAX1 D TAXHEAD
S DIR(0)="SO^1:Diagnostic/Treatment Taxonomies;2:Lab Taxonomies"
S DIR("A")="Which one"
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
I Y=1 D TAXRX Q
I Y=2 D TAXLAB Q
Q
TAXRX ;PROCESS DX/TX TAXONOMIES
S DIR(0)="SO^1:Diagnosis;2:ADA Code;3:Medication;4:Procedure (Medical);5:Patient Education Topic;6:Health Factors;7:Problem List Diagnosis"
S DIR("A")="Which one"
D DIR^BDMFDIC
I Y<1 K BDMQUIT Q
I Y=1 S BDMX="DIAGNOSIS"
I Y=2 S BDMX="ADA CODE"
I Y=3 S BDMX="RX"
I Y=4 S BDMX="PROCEDURE (MEDICAL)"
I Y=5 S BDMX="PATIENT ED TOPIC"
I Y=6 S BDMX="HEALTH FACTORS"
I Y=7 S BDMX="PROBLEM LIST DIAGNOSIS"
S X=$O(^AMQQ(5,"B",BDMX,""))
I 'X D Q
.W !!,"A taxonomy can not be created for this attribute. Ask your"
.W !,"system manager to add ",BDMX," as an attribute then try again."
S AMQQATNM=Y(0)
S AMQQATN=X
S AMQQLINK=$P(^AMQQ(5,X,0),U,5)
Q
TAXLAB ;PROCESS LAB TAXONOMIES
Q
TAXHEAD ;PRINT HEADER FOR TAXONOMY MANAGEMENT
W @IOF
N X
F X="DIABETES MANAGEMENT SYSTEM","TAXONOMY MANAGEMENT" D
.W !?(80-$L(X))\2,X
Q
SORT ;EP;FOR AUTO ADD OF NEW CMS SORT CRITERIA
S X="PRIMARY PROVIDER"
Q:$O(^ACM(48.5,"B",X,0))
S DIC="^ACM(48.5,"
S DIC(0)="L"
S DIC("DR")="1////P;4////ACM(41,;7////VA(200,"
D FILE^BDMFDIC
Q:+Y<1
S BDMDA=+Y
S ^ACM(48.5,BDMDA,1)="S ACMVAL=$P($G(^ACM(41,ACMRGDFN,""DT"")),U,15) Q:'ACMVAL S ACMVAL=$P($G(^VA(200,ACMVAL,0)),U)"
S ^ACM(48.5,BDMDA,3)="PRIMARY PROVIDER"
S $P(^ACM(48.5,BDMDA,2,0),U,2)="9002248.51P"
F BDMX="RECALL DATES","MASTER LIST","CASE REVIEW DATE","REGISTER DATA","MULTIPLE SUMMARIES","PCC HS MULTIPLE","RECALL LETTERS" D
.S X="ACM "_BDMX
.S DIC("DR")="1////"_X
.S X=$O(^DIPT("B",X,0))
.Q:'X
.S (DA,DA(1))=BDMDA
.S DIC="^ACM(48.5,"_DA_",2,"
.S DIC(0)="L"
.D FILE^BDMFDIC
Q
IDDM ;EP;TO SYNCHRONIZE DIABETES DIAGNOSES
N BDM,DR
S BDMX=""
F S BDMX=$O(^ACM(44.1,BDMX)) Q:BDMX="" D:BDMX["IDDM"
.S BDM=0
.F S BDM=$O(^ACM(44.1,"G",BDMX,BDM)) Q:'BDM D
..K DR
..I $P($G(^ACM(44.1,BDM)),U)="IDDM" S DR=".01///TYPE 1"
..I $P($G(^ACM(44.1,BDM)),U)="NIDDM" S DR=".01///TYPE 2"
..Q:$G(DR)=""
..S DA=BDM
..S DIE="^ACM(44.1,"
..D DIE^BDMFDIC
Q:'BDMRDA
F BDMX="TYPE 1","TYPE 2","IMPAIRED GLUCOSE TOLERANCE","GESTATIONAL DM" D
.S BDMDA=0
.F S BDMDA=$O(^ACM(44.1,"B",BDMX,BDMDA)) Q:'BDMDA D
..Q:$D(^ACM(44.1,BDMDA,"RG","B",BDMRDA))
..S X=BDMRDA
..S (DA,DA(1))=BDMDA
..S DIC="^ACM(44.1,"_BDMDA_",""RG"","
..S DIC(0)="L"
..S $P(^ACM(44.1,BDMDA,"RG",0),U,2)="9002244.11P"
..D FILE^BDMFDIC
Q
SWITCH ;EP;TO SWITCH REGISTERS
K BDMRDA,BDM("REGISTER")
D REG
I $D(BDMONE) D
.W !!,"If there are other DIABETES registers you need access to,"
.W !,"contact your DIABETES system manager for assistance.",!!
.H 5
.K BDMONE
Q
REG ;EP;TO SET REGISTER DATA
K BDMQUIT
I $G(BDMRDA)&($G(BDMREGNM)["") Q
D REGLIST
Q:$D(BDMQUIT)
I $D(BDMNOREG) D NEWREG K BDMNOREG G REG
Q:$D(BDMQUIT)
D DECEASED^ACMGTP(BDMRDA)
D REGVARS
D MM^BDMFMENU
Q
REGVARS ;SET REGISTER VARIABLES
S BDMREGNM=$P(^ACM(41.1,BDMRDA,0),U)
D NEWHS
D IDDM
D NEWDIAG
D NEWCOMP
Q
NEWREG ;CREATE IHS DIABETES REGISTER
S X="IHS DIABETES REGISTER"
I $D(^ACM(41.1,"B",X)) S BDMRDA=$O(^(X,0)) Q:BDMRDA
S DIC="^ACM(41.1,"
S DIC(0)="L"
D FILE^BDMFDIC
S BDMRDA=+Y
Q
NEWDIAG ;ESTABLISH IHS DIABETES REGISTER DIAGNOSES
F BDMX="TYPE 1","TYPE 2","GESTATIONAL DM","IMPAIRED GLUCOSE TOLERANCE" D
.S BDMY=$O(^ACM(44.1,"B",BDMX,0))
.I BDMY,$D(^ACM(44.1,BDMY,"RG","B",BDMRDA)) Q
.S X=BDMX
.S DIC="^ACM(44.1,"
.S DIC(0)="L"
.D FILE^BDMFDIC
.S X=BDMRDA
.S DA=+Y
.S DA(1)=+Y
.S $P(^ACM(44.1,BDMY,"RG",0),U,2)="9002244.11P"
.S DIC="^ACM(44.1,"_DA_",""RG"","
.S DIC(0)="L"
.D FILE^BDMFDIC
Q
NEWCOMP ;ESTABLISH IHS DIABETES REGISTER COMPLICATIONS
S:'$G(BDMRDA) BDMRDA=$O(^ACM(41.1,"B",BDMREGNM,0))
Q:'BDMRDA
F BDMX="CVA (STROKE)","END STAGE RENAL DISEASE","FIXED PROTEINURIA","HIGH RISK FOOT","HYPERTENSION","LASER TX FOR RETINOPATHY","MAJOR AMPUTATION(S)","MINOR AMPUTATION(S)","RETINOPATHY" D
.S BDMY=$O(^ACM(42.1,"B",BDMX,0))
.I BDMY,$D(^ACM(42.1,BDMY,"RG","B",BDMRDA)) Q
.I 'BDMY D
..S X=BDMX
..S DIC="^ACM(42.1,"
..S DIC(0)="L"
..D FILE^BDMFDIC
..S BDMY=+Y
.S X=BDMRDA
.S DA(1)=BDMY
.S $P(^ACM(42.1,BDMY,"RG",0),U,2)="9002242.11P"
.S DIC="^ACM(42.1,"_BDMY_",""RG"","
.S DIC(0)="L"
.D FILE^BDMFDIC
Q
NEWHS ;ESTABLISH NEW HEALTH SUMMARIES FOR DMS
N BDMX,BDMDA
F BDMX="DMS LAB REPORT","DMS DIABETES LAB REPORT","DMS DIABETIC FLOWSHEET" D
.S BDMDA=""
.I $D(^APCHSCTL("B",BDMX)) S BDMDA=$O(^APCHSCTL("B",BDMX,0))
.I '$G(BDMDA) D
..S X=BDMX
..S DIC="^APCHSCTL("
..S DIC(0)="LZ"
..D FILE^BDMFDIC
..S BDMDA=+Y
.Q:BDMDA<1
.I BDMX["LAB REPORT" D LAB
.I BDMX["FLOWSHEET" D FS
Q
LAB S X=$O(^APCHSCMP("B","LABORATORY DATA",0))
Q:'X
K BDMQUIT
S Y=0
F S Y=$O(^APCHSCTL(BDMDA,1,Y)) Q:'Y D
.I $P($G(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X S BDMQUIT=""
I $D(BDMQUIT) K BDMQUIT Q
S $P(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
S (DA,DA(1))=BDMDA
S DIC="^APCHSCTL("_DA_",1,"
S DIC(0)="L"
S DIC("DR")="1////"_X_";2////30;3////1Y"
S X=5
D FILE^BDMFDIC
Q:Y<1
D DMLAB:BDMX["DIABETES LAB"
Q
FS S X=$O(^APCHSCMP("B","FLOWSHEETS",0))
Q:'X
K BDMQUIT
S Y=0
F S Y=$O(^APCHSCTL(BDMDA,1,Y)) Q:'Y D
.I $P($G(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X S BDMQUIT=""
I $D(BDMQUIT) K BDMQUIT Q
S $P(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
S (DA,DA(1))=BDMDA
S DIC="^APCHSCTL("_DA_",1,"
S DIC(0)="L"
S DIC("DR")="1////"_X_";2////10;3////1Y"
S X=5
D FILE^BDMFDIC
Q:Y<1
S X=$O(^APCHSFLC("B","DIABETIC FLOWSHEET",0))
Q:'X
K BDMQUIT
S Y=0
F S Y=$O(^APCHSCTL(BDMDA,6,Y)) Q:'Y D
.I $P($G(^APCHSCTL(BDMDA,6,Y,0)),U,2)=X S BDMQUIT=""
I $D(BDMQUIT) K BDMQUIT Q
S (DA,DA(1))=BDMDA
S $P(^APCHSCTL(DA,6,0),U,2)="9001015.07IA"
S DIC="^APCHSCTL("_DA_",6,"
S DIC(0)="L"
S DIC("DR")="1////"_X
S X=5
D FILE^BDMFDIC
Q
DMLAB ;EP;SET DM LABS
S BDMJ=0
F BDMX="FASTING GTT","1/2Hr.GTT","1Hr.GTT","2Hr.GTT","3Hr.GTT","4Hr.GTT","5Hr.GTT","6Hr.GTT","FASTING GTT (URINE)","1/2Hr.GTT (URINE)","1Hr.GTT (URINE)","2Hr.GTT (URINE)","3Hr.GTT (URINE)","4Hr.GTT (URINE)","5Hr.GTT (URINE)" D D1
F BDMX="6Hr.GTT (URINE)","GLUCOSE","GLUCOSE TOLERANCE TEST","GLUCOSE, OTHER","GLUCOSE TOLERANCE (URINE)","HEMOGLOBIN A1C","SGOT","SGPT","TRIGLYCERIDE","LDL","HDL","CHOLESTEROL","LDL CHOLESTEROL" D D1
Q
D1 S X=$O(^LAB(60,"B",BDMX,0))
Q:'X
Q:$D(^APCHSCTL(BDMDA,4,"C",X))
S BDMJ=BDMJ+1
S BDMLAB=X
S X=$S($O(^APCHSCTL(BDMDA,4,99999),-1):$O(^APCHSCTL(BDMDA,4,99999),-1),1:1)
S $P(^APCHSCTL(BDMDA,4,0),U,2)="9001015.05IA"
S (DA,DA(1))=BDMDA
S DIC="^APCHSCTL("_DA_",4,"
S DIC(0)="L"
S DIC("DR")="1////"_BDMLAB
D FILE^BDMFDIC
Q
REGLIST ;EP;LIST DIABETES REGISTERS
K BDMQUIT
N J,X,Y,Z,BDM
S BDMNOREG=""
S J=0
S X=""
F S X=$O(^ACM(41.1,"B",X)) Q:X="" D
.X ^%ZOSF("UPPERCASE")
.Q:Y'["DIABET"
.K BDMNOREG
.S Y=0
.F S Y=$O(^ACM(41.1,"B",X,Y)) Q:'Y D
..S BDMNOACC=1
..Q:'$D(^ACM(41.1,+Y,"AU","B",DUZ))
..K BDMNOACC
..S J=J+1
..S BDM(J)=Y_U_X
I '$O(BDM(0)) D Q
.I $G(BDMNOACC) D Q
..W !!,"You do not have access to the DIABETES register."
..W !,"Ask your Diabetes Management System coordinator for assistance."
..S BDMQUIT="" H 5
.K BDMNOACC
K BDMQUIT
I '$O(BDM(1)) D Q
.S BDMRDA=+BDM(1)
.W !!,"You have access to the ",$P(^ACM(41.1,BDMRDA,0),U)," register,"
.S BDMONE=""
W @IOF
W !!?5,"Select DIABETES Register"
W !!?5,"---",?10,"------------------------------"
S J=0
F S J=$O(BDM(J)) Q:'J D
.W !?5,J,?10,$P(BDM(J),U,2)
.S BDMJ=J
S DIR(0)="NO^1:"_BDMJ
S DIR("A")="Which REGISTER"
W !
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMRDA=+BDM(Y)
Q
CHARTS ;EP;TO EXPORT CHART NUMBERS
K ^TMP("BDMCHART",$J)
W @IOF
S %FN="/usr/spool/uucppublic/dmschart.dat"
S BDMOP="W"
D HOST^BDMFZIS
I $D(BDMQUIT) D Q
.W !!,"The file ",%FN," could not be created."
.W !,"Consult your site manager for assistance."
.D PAUSE^BDMFMENU
S ASUFAC=$S($L($P($G(^AUTTLOC($S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,10))=6:$P(^(0),U,10),1:"ASUFAC")
S BDMX="ANMC DIABETES REGISTRY"
S BDMRDA=0
F S BDMRDA=$O(^ACM(41.1,"B",BDMX,BDMRDA)) Q:'BDMRDA D
.S X=0
.F S X=$O(^ACM(41,"B",BDMRDA,X)) Q:'X D
..Q:$E($G(^ACM(41,X,"DT")))'="A"
..S DFN=$P($G(^ACM(41,X,0)),U,2)
..S FAC=1665
..Q:'$D(^AUPNPAT(+DFN,41,FAC,0)) S CHART=$P(^(0),U,2)
..S CHART=$E("000000",1,6-$L(CHART))_CHART
..S ^TMP("BDMCHART",$J,ASUFAC,BDMX,CHART)=""
..S ^TMP("BDMCHART",$J,CHART)=""
D C1
D ^%ZISC
W !!,"The file 'dmschart.dat' has been filed in the /usr/spool/uucppublic/ directory."
D PAUSE^BDMFMENU
K ^TMP("BDMCHART",$J)
Q
C1 ;
S XX="ASUFAC"
S $E(XX,10)="REGISTER"
S $E(XX,50)="CHART"
S XX="CHART NO."
S Y=DT
X ^DD("DD")
S $E(XX,15)="File created on: "_Y
U IO W XX,!
S X=""
F S X=$O(^TMP("BDMCHART",$J,X)) Q:X="" D:X=""
.S Y=""
.F S Y=$O(^TMP("BDMCHART",$J,X,Y)) Q:Y="" D
..S Z=""
..F S Z=$O(^TMP("BDMCHART",$J,X,Y,Z)) Q:Z="" D
...S XX=X
...S $E(XX,10)=$E(Y,1,30)
...S $E(XX,50)=Z
...S XX=Z
...U IO W XX,!
...U 0 W "."
S Z=""
F S Z=$O(^TMP("BDMCHART",$J,Z)) Q:Z="" D
.U IO W Z,!
.U 0 W "."
Q
BDMFUTIL ; IHS/CMI/LAB - DMS UTILITY PROGRAM ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8**;JUN 14, 2007;Build 53
+2 ;UTILITY PROGRAM
+3 ;LOCATION FOR VARIOUS UTILITY FUNCTIONS
TAX ;EP;TAXONOMY MANAGEMENT
+1 FOR
DO TAX1
IF $DATA(BDMQUIT)!$DATA(BDMOUT)
QUIT
TAXEXIT KILL BDMQUIT,BDMOUT
+1 QUIT
TAX1 DO TAXHEAD
+1 SET DIR(0)="SO^1:Diagnostic/Treatment Taxonomies;2:Lab Taxonomies"
+2 SET DIR("A")="Which one"
+3 DO DIR^BDMFDIC
+4 IF Y<1
SET BDMQUIT=""
QUIT
+5 IF Y=1
DO TAXRX
QUIT
+6 IF Y=2
DO TAXLAB
QUIT
+7 QUIT
TAXRX ;PROCESS DX/TX TAXONOMIES
+1 SET DIR(0)="SO^1:Diagnosis;2:ADA Code;3:Medication;4:Procedure (Medical);5:Patient Education Topic;6:Health Factors;7:Problem List Diagnosis"
+2 SET DIR("A")="Which one"
+3 DO DIR^BDMFDIC
+4 IF Y<1
KILL BDMQUIT
QUIT
+5 IF Y=1
SET BDMX="DIAGNOSIS"
+6 IF Y=2
SET BDMX="ADA CODE"
+7 IF Y=3
SET BDMX="RX"
+8 IF Y=4
SET BDMX="PROCEDURE (MEDICAL)"
+9 IF Y=5
SET BDMX="PATIENT ED TOPIC"
+10 IF Y=6
SET BDMX="HEALTH FACTORS"
+11 IF Y=7
SET BDMX="PROBLEM LIST DIAGNOSIS"
+12 SET X=$ORDER(^AMQQ(5,"B",BDMX,""))
+13 IF 'X
Begin DoDot:1
+14 WRITE !!,"A taxonomy can not be created for this attribute. Ask your"
+15 WRITE !,"system manager to add ",BDMX," as an attribute then try again."
End DoDot:1
QUIT
+16 SET AMQQATNM=Y(0)
+17 SET AMQQATN=X
+18 SET AMQQLINK=$PIECE(^AMQQ(5,X,0),U,5)
+19 QUIT
TAXLAB ;PROCESS LAB TAXONOMIES
+1 QUIT
TAXHEAD ;PRINT HEADER FOR TAXONOMY MANAGEMENT
+1 WRITE @IOF
+2 NEW X
+3 FOR X="DIABETES MANAGEMENT SYSTEM","TAXONOMY MANAGEMENT"
Begin DoDot:1
+4 WRITE !?(80-$LENGTH(X))\2,X
End DoDot:1
+5 QUIT
SORT ;EP;FOR AUTO ADD OF NEW CMS SORT CRITERIA
+1 SET X="PRIMARY PROVIDER"
+2 IF $ORDER(^ACM(48.5,"B",X,0))
QUIT
+3 SET DIC="^ACM(48.5,"
+4 SET DIC(0)="L"
+5 SET DIC("DR")="1////P;4////ACM(41,;7////VA(200,"
+6 DO FILE^BDMFDIC
+7 IF +Y<1
QUIT
+8 SET BDMDA=+Y
+9 SET ^ACM(48.5,BDMDA,1)="S ACMVAL=$P($G(^ACM(41,ACMRGDFN,""DT"")),U,15) Q:'ACMVAL S ACMVAL=$P($G(^VA(200,ACMVAL,0)),U)"
+10 SET ^ACM(48.5,BDMDA,3)="PRIMARY PROVIDER"
+11 SET $PIECE(^ACM(48.5,BDMDA,2,0),U,2)="9002248.51P"
+12 FOR BDMX="RECALL DATES","MASTER LIST","CASE REVIEW DATE","REGISTER DATA","MULTIPLE SUMMARIES","PCC HS MULTIPLE","RECALL LETTERS"
Begin DoDot:1
+13 SET X="ACM "_BDMX
+14 SET DIC("DR")="1////"_X
+15 SET X=$ORDER(^DIPT("B",X,0))
+16 IF 'X
QUIT
+17 SET (DA,DA(1))=BDMDA
+18 SET DIC="^ACM(48.5,"_DA_",2,"
+19 SET DIC(0)="L"
+20 DO FILE^BDMFDIC
End DoDot:1
+21 QUIT
IDDM ;EP;TO SYNCHRONIZE DIABETES DIAGNOSES
+1 NEW BDM,DR
+2 SET BDMX=""
+3 FOR
SET BDMX=$ORDER(^ACM(44.1,BDMX))
IF BDMX=""
QUIT
IF BDMX["IDDM"
Begin DoDot:1
+4 SET BDM=0
+5 FOR
SET BDM=$ORDER(^ACM(44.1,"G",BDMX,BDM))
IF 'BDM
QUIT
Begin DoDot:2
+6 KILL DR
+7 IF $PIECE($GET(^ACM(44.1,BDM)),U)="IDDM"
SET DR=".01///TYPE 1"
+8 IF $PIECE($GET(^ACM(44.1,BDM)),U)="NIDDM"
SET DR=".01///TYPE 2"
+9 IF $GET(DR)=""
QUIT
+10 SET DA=BDM
+11 SET DIE="^ACM(44.1,"
+12 DO DIE^BDMFDIC
End DoDot:2
End DoDot:1
+13 IF 'BDMRDA
QUIT
+14 FOR BDMX="TYPE 1","TYPE 2","IMPAIRED GLUCOSE TOLERANCE","GESTATIONAL DM"
Begin DoDot:1
+15 SET BDMDA=0
+16 FOR
SET BDMDA=$ORDER(^ACM(44.1,"B",BDMX,BDMDA))
IF 'BDMDA
QUIT
Begin DoDot:2
+17 IF $DATA(^ACM(44.1,BDMDA,"RG","B",BDMRDA))
QUIT
+18 SET X=BDMRDA
+19 SET (DA,DA(1))=BDMDA
+20 SET DIC="^ACM(44.1,"_BDMDA_",""RG"","
+21 SET DIC(0)="L"
+22 SET $PIECE(^ACM(44.1,BDMDA,"RG",0),U,2)="9002244.11P"
+23 DO FILE^BDMFDIC
End DoDot:2
End DoDot:1
+24 QUIT
SWITCH ;EP;TO SWITCH REGISTERS
+1 KILL BDMRDA,BDM("REGISTER")
+2 DO REG
+3 IF $DATA(BDMONE)
Begin DoDot:1
+4 WRITE !!,"If there are other DIABETES registers you need access to,"
+5 WRITE !,"contact your DIABETES system manager for assistance.",!!
+6 HANG 5
+7 KILL BDMONE
End DoDot:1
+8 QUIT
REG ;EP;TO SET REGISTER DATA
+1 KILL BDMQUIT
+2 IF $GET(BDMRDA)&($GET(BDMREGNM)["")
QUIT
+3 DO REGLIST
+4 IF $DATA(BDMQUIT)
QUIT
+5 IF $DATA(BDMNOREG)
DO NEWREG
KILL BDMNOREG
GOTO REG
+6 IF $DATA(BDMQUIT)
QUIT
+7 DO DECEASED^ACMGTP(BDMRDA)
+8 DO REGVARS
+9 DO MM^BDMFMENU
+10 QUIT
REGVARS ;SET REGISTER VARIABLES
+1 SET BDMREGNM=$PIECE(^ACM(41.1,BDMRDA,0),U)
+2 DO NEWHS
+3 DO IDDM
+4 DO NEWDIAG
+5 DO NEWCOMP
+6 QUIT
NEWREG ;CREATE IHS DIABETES REGISTER
+1 SET X="IHS DIABETES REGISTER"
+2 IF $DATA(^ACM(41.1,"B",X))
SET BDMRDA=$ORDER(^(X,0))
IF BDMRDA
QUIT
+3 SET DIC="^ACM(41.1,"
+4 SET DIC(0)="L"
+5 DO FILE^BDMFDIC
+6 SET BDMRDA=+Y
+7 QUIT
NEWDIAG ;ESTABLISH IHS DIABETES REGISTER DIAGNOSES
+1 FOR BDMX="TYPE 1","TYPE 2","GESTATIONAL DM","IMPAIRED GLUCOSE TOLERANCE"
Begin DoDot:1
+2 SET BDMY=$ORDER(^ACM(44.1,"B",BDMX,0))
+3 IF BDMY
IF $DATA(^ACM(44.1,BDMY,"RG","B",BDMRDA))
QUIT
+4 SET X=BDMX
+5 SET DIC="^ACM(44.1,"
+6 SET DIC(0)="L"
+7 DO FILE^BDMFDIC
+8 SET X=BDMRDA
+9 SET DA=+Y
+10 SET DA(1)=+Y
+11 SET $PIECE(^ACM(44.1,BDMY,"RG",0),U,2)="9002244.11P"
+12 SET DIC="^ACM(44.1,"_DA_",""RG"","
+13 SET DIC(0)="L"
+14 DO FILE^BDMFDIC
End DoDot:1
+15 QUIT
NEWCOMP ;ESTABLISH IHS DIABETES REGISTER COMPLICATIONS
+1 IF '$GET(BDMRDA)
SET BDMRDA=$ORDER(^ACM(41.1,"B",BDMREGNM,0))
+2 IF 'BDMRDA
QUIT
+3 FOR BDMX="CVA (STROKE)","END STAGE RENAL DISEASE","FIXED PROTEINURIA","HIGH RISK FOOT","HYPERTENSION","LASER TX FOR RETINOPATHY","MAJOR AMPUTATION(S)","MINOR AMPUTATION(S)","RETINOPATHY"
Begin DoDot:1
+4 SET BDMY=$ORDER(^ACM(42.1,"B",BDMX,0))
+5 IF BDMY
IF $DATA(^ACM(42.1,BDMY,"RG","B",BDMRDA))
QUIT
+6 IF 'BDMY
Begin DoDot:2
+7 SET X=BDMX
+8 SET DIC="^ACM(42.1,"
+9 SET DIC(0)="L"
+10 DO FILE^BDMFDIC
+11 SET BDMY=+Y
End DoDot:2
+12 SET X=BDMRDA
+13 SET DA(1)=BDMY
+14 SET $PIECE(^ACM(42.1,BDMY,"RG",0),U,2)="9002242.11P"
+15 SET DIC="^ACM(42.1,"_BDMY_",""RG"","
+16 SET DIC(0)="L"
+17 DO FILE^BDMFDIC
End DoDot:1
+18 QUIT
NEWHS ;ESTABLISH NEW HEALTH SUMMARIES FOR DMS
+1 NEW BDMX,BDMDA
+2 FOR BDMX="DMS LAB REPORT","DMS DIABETES LAB REPORT","DMS DIABETIC FLOWSHEET"
Begin DoDot:1
+3 SET BDMDA=""
+4 IF $DATA(^APCHSCTL("B",BDMX))
SET BDMDA=$ORDER(^APCHSCTL("B",BDMX,0))
+5 IF '$GET(BDMDA)
Begin DoDot:2
+6 SET X=BDMX
+7 SET DIC="^APCHSCTL("
+8 SET DIC(0)="LZ"
+9 DO FILE^BDMFDIC
+10 SET BDMDA=+Y
End DoDot:2
+11 IF BDMDA<1
QUIT
+12 IF BDMX["LAB REPORT"
DO LAB
+13 IF BDMX["FLOWSHEET"
DO FS
End DoDot:1
+14 QUIT
LAB SET X=$ORDER(^APCHSCMP("B","LABORATORY DATA",0))
+1 IF 'X
QUIT
+2 KILL BDMQUIT
+3 SET Y=0
+4 FOR
SET Y=$ORDER(^APCHSCTL(BDMDA,1,Y))
IF 'Y
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X
SET BDMQUIT=""
End DoDot:1
+6 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+7 SET $PIECE(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
+8 SET (DA,DA(1))=BDMDA
+9 SET DIC="^APCHSCTL("_DA_",1,"
+10 SET DIC(0)="L"
+11 SET DIC("DR")="1////"_X_";2////30;3////1Y"
+12 SET X=5
+13 DO FILE^BDMFDIC
+14 IF Y<1
QUIT
+15 IF BDMX["DIABETES LAB"
DO DMLAB
+16 QUIT
FS SET X=$ORDER(^APCHSCMP("B","FLOWSHEETS",0))
+1 IF 'X
QUIT
+2 KILL BDMQUIT
+3 SET Y=0
+4 FOR
SET Y=$ORDER(^APCHSCTL(BDMDA,1,Y))
IF 'Y
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^APCHSCTL(BDMDA,1,Y,0)),U,2)=X
SET BDMQUIT=""
End DoDot:1
+6 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+7 SET $PIECE(^APCHSCTL(BDMDA,1,0),U,2)="9001015.01IA"
+8 SET (DA,DA(1))=BDMDA
+9 SET DIC="^APCHSCTL("_DA_",1,"
+10 SET DIC(0)="L"
+11 SET DIC("DR")="1////"_X_";2////10;3////1Y"
+12 SET X=5
+13 DO FILE^BDMFDIC
+14 IF Y<1
QUIT
+15 SET X=$ORDER(^APCHSFLC("B","DIABETIC FLOWSHEET",0))
+16 IF 'X
QUIT
+17 KILL BDMQUIT
+18 SET Y=0
+19 FOR
SET Y=$ORDER(^APCHSCTL(BDMDA,6,Y))
IF 'Y
QUIT
Begin DoDot:1
+20 IF $PIECE($GET(^APCHSCTL(BDMDA,6,Y,0)),U,2)=X
SET BDMQUIT=""
End DoDot:1
+21 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+22 SET (DA,DA(1))=BDMDA
+23 SET $PIECE(^APCHSCTL(DA,6,0),U,2)="9001015.07IA"
+24 SET DIC="^APCHSCTL("_DA_",6,"
+25 SET DIC(0)="L"
+26 SET DIC("DR")="1////"_X
+27 SET X=5
+28 DO FILE^BDMFDIC
+29 QUIT
DMLAB ;EP;SET DM LABS
+1 SET BDMJ=0
+2 FOR BDMX="FASTING GTT","1/2Hr.GTT","1Hr.GTT","2Hr.GTT","3Hr.GTT","4Hr.GTT","5Hr.GTT","6Hr.GTT","FASTING GTT (URINE)","1/2Hr.GTT (URINE)","1Hr.GTT (URINE)","2Hr.GTT (URINE)","3Hr.GTT (URINE)","4Hr.GTT (URINE)","5Hr.GTT (URINE)"
DO D1
+3 FOR BDMX="6Hr.GTT (URINE)","GLUCOSE","GLUCOSE TOLERANCE TEST","GLUCOSE, OTHER","GLUCOSE TOLERANCE (URINE)","HEMOGLOBIN A1C","SGOT","SGPT","TRIGLYCERIDE","LDL","HDL","CHOLESTEROL","LDL CHOLESTEROL"
DO D1
+4 QUIT
D1 SET X=$ORDER(^LAB(60,"B",BDMX,0))
+1 IF 'X
QUIT
+2 IF $DATA(^APCHSCTL(BDMDA,4,"C",X))
QUIT
+3 SET BDMJ=BDMJ+1
+4 SET BDMLAB=X
+5 SET X=$SELECT($ORDER(^APCHSCTL(BDMDA,4,99999),-1):$ORDER(^APCHSCTL(BDMDA,4,99999),-1),1:1)
+6 SET $PIECE(^APCHSCTL(BDMDA,4,0),U,2)="9001015.05IA"
+7 SET (DA,DA(1))=BDMDA
+8 SET DIC="^APCHSCTL("_DA_",4,"
+9 SET DIC(0)="L"
+10 SET DIC("DR")="1////"_BDMLAB
+11 DO FILE^BDMFDIC
+12 QUIT
REGLIST ;EP;LIST DIABETES REGISTERS
+1 KILL BDMQUIT
+2 NEW J,X,Y,Z,BDM
+3 SET BDMNOREG=""
+4 SET J=0
+5 SET X=""
+6 FOR
SET X=$ORDER(^ACM(41.1,"B",X))
IF X=""
QUIT
Begin DoDot:1
+7 XECUTE ^%ZOSF("UPPERCASE")
+8 IF Y'["DIABET"
QUIT
+9 KILL BDMNOREG
+10 SET Y=0
+11 FOR
SET Y=$ORDER(^ACM(41.1,"B",X,Y))
IF 'Y
QUIT
Begin DoDot:2
+12 SET BDMNOACC=1
+13 IF '$DATA(^ACM(41.1,+Y,"AU","B",DUZ))
QUIT
+14 KILL BDMNOACC
+15 SET J=J+1
+16 SET BDM(J)=Y_U_X
End DoDot:2
End DoDot:1
+17 IF '$ORDER(BDM(0))
Begin DoDot:1
+18 IF $GET(BDMNOACC)
Begin DoDot:2
+19 WRITE !!,"You do not have access to the DIABETES register."
+20 WRITE !,"Ask your Diabetes Management System coordinator for assistance."
+21 SET BDMQUIT=""
HANG 5
End DoDot:2
QUIT
+22 KILL BDMNOACC
End DoDot:1
QUIT
+23 KILL BDMQUIT
+24 IF '$ORDER(BDM(1))
Begin DoDot:1
+25 SET BDMRDA=+BDM(1)
+26 WRITE !!,"You have access to the ",$PIECE(^ACM(41.1,BDMRDA,0),U)," register,"
+27 SET BDMONE=""
End DoDot:1
QUIT
+28 WRITE @IOF
+29 WRITE !!?5,"Select DIABETES Register"
+30 WRITE !!?5,"---",?10,"------------------------------"
+31 SET J=0
+32 FOR
SET J=$ORDER(BDM(J))
IF 'J
QUIT
Begin DoDot:1
+33 WRITE !?5,J,?10,$PIECE(BDM(J),U,2)
+34 SET BDMJ=J
End DoDot:1
+35 SET DIR(0)="NO^1:"_BDMJ
+36 SET DIR("A")="Which REGISTER"
+37 WRITE !
+38 DO DIR^BDMFDIC
+39 IF Y<1
SET BDMQUIT=""
QUIT
+40 SET BDMRDA=+BDM(Y)
+41 QUIT
CHARTS ;EP;TO EXPORT CHART NUMBERS
+1 KILL ^TMP("BDMCHART",$JOB)
+2 WRITE @IOF
+3 SET %FN="/usr/spool/uucppublic/dmschart.dat"
+4 SET BDMOP="W"
+5 DO HOST^BDMFZIS
+6 IF $DATA(BDMQUIT)
Begin DoDot:1
+7 WRITE !!,"The file ",%FN," could not be created."
+8 WRITE !,"Consult your site manager for assistance."
+9 DO PAUSE^BDMFMENU
End DoDot:1
QUIT
+10 SET ASUFAC=$SELECT($LENGTH($PIECE($GET(^AUTTLOC($SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,10))=6:$PIECE(^(0),U,10),1:"ASUFAC")
+11 SET BDMX="ANMC DIABETES REGISTRY"
+12 SET BDMRDA=0
+13 FOR
SET BDMRDA=$ORDER(^ACM(41.1,"B",BDMX,BDMRDA))
IF 'BDMRDA
QUIT
Begin DoDot:1
+14 SET X=0
+15 FOR
SET X=$ORDER(^ACM(41,"B",BDMRDA,X))
IF 'X
QUIT
Begin DoDot:2
+16 IF $EXTRACT($GET(^ACM(41,X,"DT")))'="A"
QUIT
+17 SET DFN=$PIECE($GET(^ACM(41,X,0)),U,2)
+18 SET FAC=1665
+19 IF '$DATA(^AUPNPAT(+DFN,41,FAC,0))
QUIT
SET CHART=$PIECE(^(0),U,2)
+20 SET CHART=$EXTRACT("000000",1,6-$LENGTH(CHART))_CHART
+21 SET ^TMP("BDMCHART",$JOB,ASUFAC,BDMX,CHART)=""
+22 SET ^TMP("BDMCHART",$JOB,CHART)=""
End DoDot:2
End DoDot:1
+23 DO C1
+24 DO ^%ZISC
+25 WRITE !!,"The file 'dmschart.dat' has been filed in the /usr/spool/uucppublic/ directory."
+26 DO PAUSE^BDMFMENU
+27 KILL ^TMP("BDMCHART",$JOB)
+28 QUIT
C1 ;
+1 SET XX="ASUFAC"
+2 SET $EXTRACT(XX,10)="REGISTER"
+3 SET $EXTRACT(XX,50)="CHART"
+4 SET XX="CHART NO."
+5 SET Y=DT
+6 XECUTE ^DD("DD")
+7 SET $EXTRACT(XX,15)="File created on: "_Y
+8 USE IO
WRITE XX,!
+9 SET X=""
+10 FOR
SET X=$ORDER(^TMP("BDMCHART",$JOB,X))
IF X=""
QUIT
IF X=""
Begin DoDot:1
+11 SET Y=""
+12 FOR
SET Y=$ORDER(^TMP("BDMCHART",$JOB,X,Y))
IF Y=""
QUIT
Begin DoDot:2
+13 SET Z=""
+14 FOR
SET Z=$ORDER(^TMP("BDMCHART",$JOB,X,Y,Z))
IF Z=""
QUIT
Begin DoDot:3
+15 SET XX=X
+16 SET $EXTRACT(XX,10)=$EXTRACT(Y,1,30)
+17 SET $EXTRACT(XX,50)=Z
+18 SET XX=Z
+19 USE IO
WRITE XX,!
+20 USE 0
WRITE "."
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET Z=""
+22 FOR
SET Z=$ORDER(^TMP("BDMCHART",$JOB,Z))
IF Z=""
QUIT
Begin DoDot:1
+23 USE IO
WRITE Z,!
+24 USE 0
WRITE "."
End DoDot:1
+25 QUIT
