BDMVRL5 ; IHS/CMI/LAB - VIEW PT RECORD LT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**4,12**;JUN 14, 2007;Build 51
;
PAUSE ;EP; -- end of action pause
D RETURN^BDMVU
Q
;
GETPAT ;EP; -- ask user to select patient
K DIC,DFN,BDMQUIT
S DIC=9000001
S DIC(0)="AEMQZ"
S AUPNLK("INAC")="" ;1/25/2007 allow lookup of inactive patients
D DIC^BDMFDIC
I $G(Y)<1 S BDMQUIT="" K AUPNLK("INAC") Q
K AUPNLK("INAC") ;1/25/2007 allow lookup of inactive patients
S DFN=+Y
S BDMPAT0=$G(Y(0,0))
D REGPAT
Q:$D(BDMQUIT)
D DOB
D AGE
D HRN
D RES(DFN)
D DX
D COMP
K BDMQUIT
Q
;
GETHSTYP ;EP; -- ask user for health summary type
N DIC,DR,DD,X
S X=""
I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,3)
S:X="" X="ADULT REGULAR"
S DIC="^APCHSCTL("
S DIC(0)="AEMQ"
S DIC("B")=X
W !
D DIC^BDMFDIC
Q:Y<1
S APCHSTYP=+Y
Q
REGPAT ;REGISTER AND PATIENT VARIABLES
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMRPDA=$G(^ACM(41,"AC",DFN,BDMRDA))
I 'BDMRPDA D NEWPAT
D PAT^BDMVRL4(DFN,BDMRPDA)
;D INA(DFN,BDMRPDA)
Q
;
INA(DFN,ACMRPDA) ;EP - check to see if patient is inactive
;cmi/anch/maw 1/25/2007 added per DKR
Q:'ACMRPDA
Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)=""
Q:$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)'="I"
S DA=ACMRPDA
S DIE="^ACM(41,"
S DR="1////I"
D DIE^BDMFDIC
Q
;
NEWPAT ;EP;CREATE ENTRY FOR NEW REGISTER PATIENT
D NEWPAT^BDMVRL2
Q
DXUPD ;EP;UPDATE PATIENT'S DIABETIC DIAGNOSIS
N X,Y,Z
I BDMEXT=""!(BDMEXT'=BDMEXTIN) D Q:BDMEXT=""
.S DA=$P($G(BDM("DX",1)),U,2)
.Q:'DA
.S DIK="^ACM(44,"
.D ^DIK
S:'$D(BDM("DX",1)) $P(BDM("DX",1),U)=$P($G(BDMEXT),U)
S Y=$P(BDM("DX",1),U)
I Y=$G(BDMDX) K BDMDX Q
S:$G(BDMEXT)]"" BDMX=$O(^ACM(44.1,"B",$P(BDMEXT,U),0))
I $G(BDMX) S BDMX=$P(^ACM(44.1,BDMX,0),U) ;cmi/maw 9/7/06 added due to not allowed 4 slash on .01 below
Q:$G(BDMX)=""
S DA=""
S X=0
F S X=$O(BDM("DX",X)) Q:'X D
.I $P(BDM("DX",X),U)=$P(BDMEXT,U) S DA=$P(BDM("DX",X),U,2)
I DA D Q
.S DIE="^ACM(44,"
.S DR=".01///"_BDMX_";2////"_$G(BDM("ONSET"))
.D DIE^BDMFDIC
S X=BDMX
S DIC="^ACM(44,"
S DIC(0)="L"
S DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA_";2////"_$G(BDM("ONSET"))
D FILE^BDMFDIC
Q
GRD ;EP;PATIENT REGISTER DATA
Q:'$G(BDMRPDA)
N X,Y,Z
S BDMREG0=$G(^ACM(41,BDMRPDA,0))
S BDMREGDT=$G(^ACM(41,BDMRPDA,"DT"))
S BDMCH=$G(^ACM(41,BDMRPDA,"CH"))
S:'$G(DFN) DFN=$P(BDMREG0,U,2)
S X=$P($G(^DPT(+DFN,0)),U)
D 30
S BDM("PATIENT")=X
S X=$P(BDMREGDT,U)
S X=$P($P($P(^DD(9002241,1,0),U,3),(X_":"),2),";")
D 30
S BDM("STATUS")=X
S X=$P(BDMREGDT,U,5)
S X=$P($P($P(^DD(9002241,5,0),U,3),(X_":"),2),";")
D 30
S BDM("CASE PRIORITY")=X
S X=$P(BDMREGDT,U,6)
S X=$P($G(^VA(200,+X,0)),U)
D 30
S BDM("CASE MANAGER")=X
S X=$P(BDMREGDT,U,7)
S X=$P($G(^VA(200,+X,0)),U)
D 30
S BDM("PUBLIC HLTH NURSE")=X
S X=$P(BDMREGDT,U,10)
S X=$P($G(^DIC(4,+X,0)),U)
D 30
S BDM("WHERE FOLLOWED")=X
S X=$P(BDMREGDT,U,13)
D 30
S BDM("CLIENT CONTACT")=X
S X=$P($G(^AUPNPAT(DFN,0)),U,14)
S X=$S($G(^DD(9000001,.14,0))[200:$P($G(^VA(200,+X,0)),U),1:$P($G(^DIC(16,+X,0)),U))
D 30
S BDM("PRIMARY PROVIDER")=X
S X=$P(BDMREGDT,U,15)
S X=$P($G(^VA(200,+X,0)),U)
D 30
S BDM("REGISTER PROVIDER")=X
S X=$P(BDMREGDT,U,14)
S X=$P($P($P(^DD(9002241,15.1,0),U,3),(X_":"),2),";")
D 30
S BDM("PROVIDER CATEGORY")=X
S Y=$P(BDMREGDT,U,2)
X ^DD("DD")
D 15
S BDM("DATE ACTIVATED")=Y
S Y=$P(BDMREGDT,U,3)
X ^DD("DD")
D 15
S BDM("DATE INACTIVATED")=Y
S Y=$P(BDMREGDT,U,4)
X ^DD("DD")
D 15
S BDM("INITIAL ENTRY DATE")=Y
S Y=$P(BDMREGDT,U,11)
X ^DD("DD")
D 15
S BDM("DATE LAST EDITED")=Y
S Y=$P(BDMREGDT,U,8)
X ^DD("DD")
D 15
S BDM("LAST REVIEW DATE")=Y
S Y=$P(BDMREGDT,U,9)
X ^DD("DD")
D 15
S BDM("NEXT REVIEW DATE")=Y
D DOB
D AGE
D HRN
D RES(DFN)
D DX
D COMP
Q
DOB ;DATE OF BIRTH
N X,Y,Z
K BDM("DOB")
S Y=$P(^DPT(DFN,0),U,3)
S BDM("DOB")=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$S($E(Y,1,3)>299:20_$E(Y,2,3),1:(19_$E(Y,2,3)))
S Z=""
S X=$G(^DPT(DFN,.11))
F J=1:1:6 I $P(X,U,J)]"" S Y=$P(X,U,J) S:J=5 Y=$P($G(^DIC(5,+Y,0)),U,2) S Z=Z_Y S:J'=6 Z=Z_","
S BDM("ADDRESS")=Z
S BDM("PHONE")=$P($G(^DPT(DFN,.13)),U)
Q
AGE ;PATIENT AGE
N X,Y,Z
K BDM("AGE")
S X=$P(^DPT(DFN,0),U,3)
S Y=$E(DT,1,3)
S Z=$E(Y,1,3)-$E(X,1,3)
S:$E(X,4,7)>$E(DT,4,7) Z=Z-1
S BDM("AGE")=Z
Q
HRN ;HRN
S BDM("HRN")=$P($G(^AUPNPAT(DFN,41,+$G(DUZ(2)),0)),U,2)
Q
RES(DFN) ;EP;CURRENT RESIDENCE
N X
S X=$O(^AUPNPAT(DFN,51,99999999),-1)
S:X X=$P($G(^AUPNPAT(DFN,51,X,0)),U,3)
S:'X X=+$P($G(^AUPNPAT(DFN,11)),U,17)
I 'X S X=$P($G(^AUPNPAT(DFN,11)),U,18) S:X]"" X=$O(^AUTTCOM("B",X,0))
S (BDM,BDM("RES"))=X
Q
DX ;DIABETIC DIAGNOSES
K BDM("DX")
N X,Y,Z
S (BDMEXT,BDMEXTIN)=""
S (X,Z)=0
F S X=$O(^ACM(44,"C",DFN,X)) Q:'X D
.S Y=$G(^ACM(44,X,0))
.Q:'Y
.Q:$P(Y,U,4)'=BDMRDA
.S Y=$G(^ACM(44.1,+Y,0))
.S Z=Z+1
.D DD
.S BDM("DX",Z)=$P(Y,U)_U_X_U_BDM("ONSET DISPLAY")
.S:Z=1 (BDMEXT,BDMEXTIN)=$P(Y,U)
S Z=1
S X=$O(^ACM(44,"C",DFN,X))
D:X DD
Q
S BDMX=1
F S BDMX=$O(BDM("DX",BDMX)) Q:'BDMX D
.S DA=$P(BDM("DX",BDMX),U,2)
.Q:'DA
.S DIK="^ACM(44.,"
.D DIK^BDMFDIC
.K BDM("DX",BDMX)
Q
DD ;ONSET DATE
N Y
S Y=$P($G(^ACM(44,X,"SV")),U,2)
X:Y ^DD("DD")
S BDM("ONSET DISPLAY")=Y
Q
30 ;PAD TO 30 CHARACTERS
S X=X_$E(" ",1,30-$L(X))
Q
15 ;PAD TO 15 CHARACTERS
S Y=Y_$E(" ",1,15-$L(Y))
Q
COMP ;PATIENT'S COMPLICATIONS
K BDM("COMP")
N X,Y,Z
S (X,Z)=0
F S X=$O(^ACM(42,"C",DFN,X)) Q:'X D
.S ACM0=$G(^ACM(42,X,0))
.Q:'ACM0
.Q:$P(ACM0,U,4)'=BDMRDA
.S Y=$G(^ACM(42.1,+ACM0,0))
.S Z=Z+1
.S BDM("COMP",Z)=$P(Y,U)
.S Y=$P($G(^ACM(42,X,"DT")),U)
.X ^DD("DD")
.S BDM("COMP",Z)=BDM("COMP",Z)_U_Y
Q
PP ;EP;PRIMARY CARE PROVIDER
Q
Q:$G(^DD(9000001,.14,0))[200
N BDMPP,BDMPP6
I $P($G(^AUPNPAT(+$G(DFN),0)),U,14) D
.S BDMPP6=$P(^AUPNPAT(DFN,0),U,14)
.S BDMPP=$O(^VA(200,"A16",+$G(BDMPP6),0))
I '$G(BDMPP) D
.S BDMPP=$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
.Q:'BDMPP
.S BDMPP6=$P($G(^VA(200,BDMPP,0)),U,16)
.S DA=DFN
.S DIE="^AUPNPAT("
.S DR=".14////"_BDMPP6
.D DIE^BDMFDIC
Q:$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
S DA=BDMRPDA
S DIE="^ACM(41,"
S DR="15////"_BDMPP
D DIE^BDMFDIC
Q
CONTACT ;CLIENT CONTACT INFO
Q:$P($G(^ACM(41,BDMRPDA,"DT")),U,13)]""
N X,Y,Z
S Z=""
S X=$G(^DPT(DFN,.11))
F J=1:1:6 I $P(X,U,J)]"" S Y=$P(X,U,J) S:J=5 Y=$P($G(^DIC(5,+Y,0)),U,2) S Z=Z_Y_","
S X=$P($G(^DPT(DFN,.13)),U)
S DA=BDMRPDA
S DIE="^ACM(41,"
S DR="14////"_Z_" "_X
D DIE^BDMFDIC
Q
NOREG ;EP;NO DIABETES REGISTER ON THE SYSTEM
D CLEAR^VALM1
W !!,"There is no IHS DIABETES REGISTER on this system."
S DIR(0)="YO"
S DIR("A")="Create the IHS DIABETES REGISTER now?"
S DIR("B")="NO"
W !
D DIR^BDMFDIC
I Y'=1 S BDMQUIT="" Q
NR1 ;EP;CREATE NEW IHS DIABETES REGISTER
D NEWREG
D NEWDIAG
D NEWCOMP
D NEWHS
Q
NEWREG ;CREATE IHS DIABETES REGISTER
S X=BDMREGNM
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 ;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
.I 'BDMY D
..S X=BDMX
..S DIC="^ACM(44.1,"
..S DIC(0)="L"
..D FILE^BDMFDIC
..S BDMY=+Y
.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 ;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=+Y
.S DA(1)=+Y
.S $P(^ACM(42.1,DA,"RG",0),U,2)="9002242.11P"
.S DIC="^ACM(42.1,"_DA_",""RG"","
.S DIC(0)="L"
.D FILE^BDMFDIC
Q
NEWHS ;EP;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^BDMFUTIL: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
BDMVRL5 ; IHS/CMI/LAB - VIEW PT RECORD LT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**4,12**;JUN 14, 2007;Build 51
+2 ;
PAUSE ;EP; -- end of action pause
+1 DO RETURN^BDMVU
+2 QUIT
+3 ;
GETPAT ;EP; -- ask user to select patient
+1 KILL DIC,DFN,BDMQUIT
+2 SET DIC=9000001
+3 SET DIC(0)="AEMQZ"
+4 ;1/25/2007 allow lookup of inactive patients
SET AUPNLK("INAC")=""
+5 DO DIC^BDMFDIC
+6 IF $GET(Y)<1
SET BDMQUIT=""
KILL AUPNLK("INAC")
QUIT
+7 ;1/25/2007 allow lookup of inactive patients
KILL AUPNLK("INAC")
+8 SET DFN=+Y
+9 SET BDMPAT0=$GET(Y(0,0))
+10 DO REGPAT
+11 IF $DATA(BDMQUIT)
QUIT
+12 DO DOB
+13 DO AGE
+14 DO HRN
+15 DO RES(DFN)
+16 DO DX
+17 DO COMP
+18 KILL BDMQUIT
+19 QUIT
+20 ;
GETHSTYP ;EP; -- ask user for health summary type
+1 NEW DIC,DR,DD,X
+2 SET X=""
+3 IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,3)
+4 IF X=""
SET X="ADULT REGULAR"
+5 SET DIC="^APCHSCTL("
+6 SET DIC(0)="AEMQ"
+7 SET DIC("B")=X
+8 WRITE !
+9 DO DIC^BDMFDIC
+10 IF Y<1
QUIT
+11 SET APCHSTYP=+Y
+12 QUIT
REGPAT ;REGISTER AND PATIENT VARIABLES
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMRPDA=$GET(^ACM(41,"AC",DFN,BDMRDA))
+4 IF 'BDMRPDA
DO NEWPAT
+5 DO PAT^BDMVRL4(DFN,BDMRPDA)
+6 ;D INA(DFN,BDMRPDA)
+7 QUIT
+8 ;
INA(DFN,ACMRPDA) ;EP - check to see if patient is inactive
+1 ;cmi/anch/maw 1/25/2007 added per DKR
+2 IF 'ACMRPDA
QUIT
+3 IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)=""
QUIT
+4 IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)'="I"
QUIT
+5 SET DA=ACMRPDA
+6 SET DIE="^ACM(41,"
+7 SET DR="1////I"
+8 DO DIE^BDMFDIC
+9 QUIT
+10 ;
NEWPAT ;EP;CREATE ENTRY FOR NEW REGISTER PATIENT
+1 DO NEWPAT^BDMVRL2
+2 QUIT
DXUPD ;EP;UPDATE PATIENT'S DIABETIC DIAGNOSIS
+1 NEW X,Y,Z
+2 IF BDMEXT=""!(BDMEXT'=BDMEXTIN)
Begin DoDot:1
+3 SET DA=$PIECE($GET(BDM("DX",1)),U,2)
+4 IF 'DA
QUIT
+5 SET DIK="^ACM(44,"
+6 DO ^DIK
End DoDot:1
IF BDMEXT=""
QUIT
+7 IF '$DATA(BDM("DX",1))
SET $PIECE(BDM("DX",1),U)=$PIECE($GET(BDMEXT),U)
+8 SET Y=$PIECE(BDM("DX",1),U)
+9 IF Y=$GET(BDMDX)
KILL BDMDX
QUIT
+10 IF $GET(BDMEXT)]""
SET BDMX=$ORDER(^ACM(44.1,"B",$PIECE(BDMEXT,U),0))
+11 ;cmi/maw 9/7/06 added due to not allowed 4 slash on .01 below
IF $GET(BDMX)
SET BDMX=$PIECE(^ACM(44.1,BDMX,0),U)
+12 IF $GET(BDMX)=""
QUIT
+13 SET DA=""
+14 SET X=0
+15 FOR
SET X=$ORDER(BDM("DX",X))
IF 'X
QUIT
Begin DoDot:1
+16 IF $PIECE(BDM("DX",X),U)=$PIECE(BDMEXT,U)
SET DA=$PIECE(BDM("DX",X),U,2)
End DoDot:1
+17 IF DA
Begin DoDot:1
+18 SET DIE="^ACM(44,"
+19 SET DR=".01///"_BDMX_";2////"_$GET(BDM("ONSET"))
+20 DO DIE^BDMFDIC
End DoDot:1
QUIT
+21 SET X=BDMX
+22 SET DIC="^ACM(44,"
+23 SET DIC(0)="L"
+24 SET DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA_";2////"_$GET(BDM("ONSET"))
+25 DO FILE^BDMFDIC
+26 QUIT
GRD ;EP;PATIENT REGISTER DATA
+1 IF '$GET(BDMRPDA)
QUIT
+2 NEW X,Y,Z
+3 SET BDMREG0=$GET(^ACM(41,BDMRPDA,0))
+4 SET BDMREGDT=$GET(^ACM(41,BDMRPDA,"DT"))
+5 SET BDMCH=$GET(^ACM(41,BDMRPDA,"CH"))
+6 IF '$GET(DFN)
SET DFN=$PIECE(BDMREG0,U,2)
+7 SET X=$PIECE($GET(^DPT(+DFN,0)),U)
+8 DO 30
+9 SET BDM("PATIENT")=X
+10 SET X=$PIECE(BDMREGDT,U)
+11 SET X=$PIECE($PIECE($PIECE(^DD(9002241,1,0),U,3),(X_":"),2),";")
+12 DO 30
+13 SET BDM("STATUS")=X
+14 SET X=$PIECE(BDMREGDT,U,5)
+15 SET X=$PIECE($PIECE($PIECE(^DD(9002241,5,0),U,3),(X_":"),2),";")
+16 DO 30
+17 SET BDM("CASE PRIORITY")=X
+18 SET X=$PIECE(BDMREGDT,U,6)
+19 SET X=$PIECE($GET(^VA(200,+X,0)),U)
+20 DO 30
+21 SET BDM("CASE MANAGER")=X
+22 SET X=$PIECE(BDMREGDT,U,7)
+23 SET X=$PIECE($GET(^VA(200,+X,0)),U)
+24 DO 30
+25 SET BDM("PUBLIC HLTH NURSE")=X
+26 SET X=$PIECE(BDMREGDT,U,10)
+27 SET X=$PIECE($GET(^DIC(4,+X,0)),U)
+28 DO 30
+29 SET BDM("WHERE FOLLOWED")=X
+30 SET X=$PIECE(BDMREGDT,U,13)
+31 DO 30
+32 SET BDM("CLIENT CONTACT")=X
+33 SET X=$PIECE($GET(^AUPNPAT(DFN,0)),U,14)
+34 SET X=$SELECT($GET(^DD(9000001,.14,0))[200:$PIECE($GET(^VA(200,+X,0)),U),1:$PIECE($GET(^DIC(16,+X,0)),U))
+35 DO 30
+36 SET BDM("PRIMARY PROVIDER")=X
+37 SET X=$PIECE(BDMREGDT,U,15)
+38 SET X=$PIECE($GET(^VA(200,+X,0)),U)
+39 DO 30
+40 SET BDM("REGISTER PROVIDER")=X
+41 SET X=$PIECE(BDMREGDT,U,14)
+42 SET X=$PIECE($PIECE($PIECE(^DD(9002241,15.1,0),U,3),(X_":"),2),";")
+43 DO 30
+44 SET BDM("PROVIDER CATEGORY")=X
+45 SET Y=$PIECE(BDMREGDT,U,2)
+46 XECUTE ^DD("DD")
+47 DO 15
+48 SET BDM("DATE ACTIVATED")=Y
+49 SET Y=$PIECE(BDMREGDT,U,3)
+50 XECUTE ^DD("DD")
+51 DO 15
+52 SET BDM("DATE INACTIVATED")=Y
+53 SET Y=$PIECE(BDMREGDT,U,4)
+54 XECUTE ^DD("DD")
+55 DO 15
+56 SET BDM("INITIAL ENTRY DATE")=Y
+57 SET Y=$PIECE(BDMREGDT,U,11)
+58 XECUTE ^DD("DD")
+59 DO 15
+60 SET BDM("DATE LAST EDITED")=Y
+61 SET Y=$PIECE(BDMREGDT,U,8)
+62 XECUTE ^DD("DD")
+63 DO 15
+64 SET BDM("LAST REVIEW DATE")=Y
+65 SET Y=$PIECE(BDMREGDT,U,9)
+66 XECUTE ^DD("DD")
+67 DO 15
+68 SET BDM("NEXT REVIEW DATE")=Y
+69 DO DOB
+70 DO AGE
+71 DO HRN
+72 DO RES(DFN)
+73 DO DX
+74 DO COMP
+75 QUIT
DOB ;DATE OF BIRTH
+1 NEW X,Y,Z
+2 KILL BDM("DOB")
+3 SET Y=$PIECE(^DPT(DFN,0),U,3)
+4 SET BDM("DOB")=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_$SELECT($EXTRACT(Y,1,3)>299:20_$EXTRACT(Y,2,3),1:(19_$EXTRACT(Y,2,3)))
+5 SET Z=""
+6 SET X=$GET(^DPT(DFN,.11))
+7 FOR J=1:1:6
IF $PIECE(X,U,J)]""
SET Y=$PIECE(X,U,J)
IF J=5
SET Y=$PIECE($GET(^DIC(5,+Y,0)),U,2)
SET Z=Z_Y
IF J'=6
SET Z=Z_","
+8 SET BDM("ADDRESS")=Z
+9 SET BDM("PHONE")=$PIECE($GET(^DPT(DFN,.13)),U)
+10 QUIT
AGE ;PATIENT AGE
+1 NEW X,Y,Z
+2 KILL BDM("AGE")
+3 SET X=$PIECE(^DPT(DFN,0),U,3)
+4 SET Y=$EXTRACT(DT,1,3)
+5 SET Z=$EXTRACT(Y,1,3)-$EXTRACT(X,1,3)
+6 IF $EXTRACT(X,4,7)>$EXTRACT(DT,4,7)
SET Z=Z-1
+7 SET BDM("AGE")=Z
+8 QUIT
HRN ;HRN
+1 SET BDM("HRN")=$PIECE($GET(^AUPNPAT(DFN,41,+$GET(DUZ(2)),0)),U,2)
+2 QUIT
RES(DFN) ;EP;CURRENT RESIDENCE
+1 NEW X
+2 SET X=$ORDER(^AUPNPAT(DFN,51,99999999),-1)
+3 IF X
SET X=$PIECE($GET(^AUPNPAT(DFN,51,X,0)),U,3)
+4 IF 'X
SET X=+$PIECE($GET(^AUPNPAT(DFN,11)),U,17)
+5 IF 'X
SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF X]""
SET X=$ORDER(^AUTTCOM("B",X,0))
+6 SET (BDM,BDM("RES"))=X
+7 QUIT
DX ;DIABETIC DIAGNOSES
+1 KILL BDM("DX")
+2 NEW X,Y,Z
+3 SET (BDMEXT,BDMEXTIN)=""
+4 SET (X,Z)=0
+5 FOR
SET X=$ORDER(^ACM(44,"C",DFN,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET Y=$GET(^ACM(44,X,0))
+7 IF 'Y
QUIT
+8 IF $PIECE(Y,U,4)'=BDMRDA
QUIT
+9 SET Y=$GET(^ACM(44.1,+Y,0))
+10 SET Z=Z+1
+11 DO DD
+12 SET BDM("DX",Z)=$PIECE(Y,U)_U_X_U_BDM("ONSET DISPLAY")
+13 IF Z=1
SET (BDMEXT,BDMEXTIN)=$PIECE(Y,U)
End DoDot:1
+14 SET Z=1
+15 SET X=$ORDER(^ACM(44,"C",DFN,X))
+16 IF X
DO DD
+17 QUIT
+18 SET BDMX=1
+19 FOR
SET BDMX=$ORDER(BDM("DX",BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+20 SET DA=$PIECE(BDM("DX",BDMX),U,2)
+21 IF 'DA
QUIT
+22 SET DIK="^ACM(44.,"
+23 DO DIK^BDMFDIC
+24 KILL BDM("DX",BDMX)
End DoDot:1
+25 QUIT
DD ;ONSET DATE
+1 NEW Y
+2 SET Y=$PIECE($GET(^ACM(44,X,"SV")),U,2)
+3 IF Y
XECUTE ^DD("DD")
+4 SET BDM("ONSET DISPLAY")=Y
+5 QUIT
30 ;PAD TO 30 CHARACTERS
+1 SET X=X_$EXTRACT(" ",1,30-$LENGTH(X))
+2 QUIT
15 ;PAD TO 15 CHARACTERS
+1 SET Y=Y_$EXTRACT(" ",1,15-$LENGTH(Y))
+2 QUIT
COMP ;PATIENT'S COMPLICATIONS
+1 KILL BDM("COMP")
+2 NEW X,Y,Z
+3 SET (X,Z)=0
+4 FOR
SET X=$ORDER(^ACM(42,"C",DFN,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET ACM0=$GET(^ACM(42,X,0))
+6 IF 'ACM0
QUIT
+7 IF $PIECE(ACM0,U,4)'=BDMRDA
QUIT
+8 SET Y=$GET(^ACM(42.1,+ACM0,0))
+9 SET Z=Z+1
+10 SET BDM("COMP",Z)=$PIECE(Y,U)
+11 SET Y=$PIECE($GET(^ACM(42,X,"DT")),U)
+12 XECUTE ^DD("DD")
+13 SET BDM("COMP",Z)=BDM("COMP",Z)_U_Y
End DoDot:1
+14 QUIT
PP ;EP;PRIMARY CARE PROVIDER
+1 QUIT
+2 IF $GET(^DD(9000001,.14,0))[200
QUIT
+3 NEW BDMPP,BDMPP6
+4 IF $PIECE($GET(^AUPNPAT(+$GET(DFN),0)),U,14)
Begin DoDot:1
+5 SET BDMPP6=$PIECE(^AUPNPAT(DFN,0),U,14)
+6 SET BDMPP=$ORDER(^VA(200,"A16",+$GET(BDMPP6),0))
End DoDot:1
+7 IF '$GET(BDMPP)
Begin DoDot:1
+8 SET BDMPP=$PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,15)
+9 IF 'BDMPP
QUIT
+10 SET BDMPP6=$PIECE($GET(^VA(200,BDMPP,0)),U,16)
+11 SET DA=DFN
+12 SET DIE="^AUPNPAT("
+13 SET DR=".14////"_BDMPP6
+14 DO DIE^BDMFDIC
End DoDot:1
+15 IF $PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,15)
QUIT
+16 SET DA=BDMRPDA
+17 SET DIE="^ACM(41,"
+18 SET DR="15////"_BDMPP
+19 DO DIE^BDMFDIC
+20 QUIT
CONTACT ;CLIENT CONTACT INFO
+1 IF $PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,13)]""
QUIT
+2 NEW X,Y,Z
+3 SET Z=""
+4 SET X=$GET(^DPT(DFN,.11))
+5 FOR J=1:1:6
IF $PIECE(X,U,J)]""
SET Y=$PIECE(X,U,J)
IF J=5
SET Y=$PIECE($GET(^DIC(5,+Y,0)),U,2)
SET Z=Z_Y_","
+6 SET X=$PIECE($GET(^DPT(DFN,.13)),U)
+7 SET DA=BDMRPDA
+8 SET DIE="^ACM(41,"
+9 SET DR="14////"_Z_" "_X
+10 DO DIE^BDMFDIC
+11 QUIT
NOREG ;EP;NO DIABETES REGISTER ON THE SYSTEM
+1 DO CLEAR^VALM1
+2 WRITE !!,"There is no IHS DIABETES REGISTER on this system."
+3 SET DIR(0)="YO"
+4 SET DIR("A")="Create the IHS DIABETES REGISTER now?"
+5 SET DIR("B")="NO"
+6 WRITE !
+7 DO DIR^BDMFDIC
+8 IF Y'=1
SET BDMQUIT=""
QUIT
NR1 ;EP;CREATE NEW IHS DIABETES REGISTER
+1 DO NEWREG
+2 DO NEWDIAG
+3 DO NEWCOMP
+4 DO NEWHS
+5 QUIT
NEWREG ;CREATE IHS DIABETES REGISTER
+1 SET X=BDMREGNM
+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 ;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 IF 'BDMY
Begin DoDot:2
+5 SET X=BDMX
+6 SET DIC="^ACM(44.1,"
+7 SET DIC(0)="L"
+8 DO FILE^BDMFDIC
+9 SET BDMY=+Y
End DoDot:2
+10 SET X=BDMRDA
+11 SET DA=+Y
+12 SET DA(1)=+Y
+13 SET $PIECE(^ACM(44.1,BDMY,"RG",0),U,2)="9002244.11P"
+14 SET DIC="^ACM(44.1,"_DA_",""RG"","
+15 SET DIC(0)="L"
+16 DO FILE^BDMFDIC
End DoDot:1
+17 QUIT
NEWCOMP ;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=+Y
+14 SET DA(1)=+Y
+15 SET $PIECE(^ACM(42.1,DA,"RG",0),U,2)="9002242.11P"
+16 SET DIC="^ACM(42.1,"_DA_",""RG"","
+17 SET DIC(0)="L"
+18 DO FILE^BDMFDIC
End DoDot:1
+19 QUIT
NEWHS ;EP;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^BDMFUTIL
+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
