BDMVRL3 ; cmi/anch/maw - VIEW PT RECORD CON'T ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**9,12**;JUN 14, 2007;Build 51
;
;
CDISP ;EP;DISPLAY AND EDIT COMPLICATIONS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV COMPLICATIONS"
D VALM^BDMVRL(BDMVALM)
Q
CADD ;EP;TO ADD COMPLICATION
D REG^BDMFUTIL
Q:$D(BDMQUIT)
W !?5,"ADD Complications for ",$P(BDMPAT0,U)
D CLIST
Q:'$G(BDMJ)
S DIR(0)="LO^1:"_BDMJ
S DIR("A")="Which COMPLICATION(S)"
W !
D DIR^BDMFDIC
Q:+Y<1
F BDMJ=1:1 S BDMX=$P(BDMY,",",BDMJ) Q:'BDMX D CADD1:$D(BDM("COMPLICATIONS",BDMX))
K BDM("COMPLICATIONS")
Q
CADD1 ;
S X=+BDM("COMPLICATIONS",BDMX)
I $D(^ACM(42,"AC",BDMRPDA,DFN,X)) W !!,"Patient already has ",$P(^ACM(42.1,X,0),U)," as a complication. Use Edit or Delete to modify this complication." D PAUSE Q
S DIC="^ACM(42,"
S DIC(0)="L"
S DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA
D FILE^BDMFDIC
;EDIT COMPLICATION WHEN ADDED
Q:+Y<1
S BDMCDA=+Y
D CE1
Q
CEDIT ;EP;TO EDIT COMPLICATION
D REG^BDMFUTIL
Q:$D(BDMQUIT)
D CSEL
I $D(BDMQUIT) K BDMQUIT Q
N BDMX,BDMZ
F BDMJ=1:1 S BDMX=$P(BDMY,",",BDMJ) Q:BDMX="" I $D(BDM("COMP",BDMX)) S BDMCDA=+$G(BDM("COMP",BDMX)) D CE1
Q
CE1 S DA=BDMCDA
S DIE="^ACM(42,"
S DR="[BDM COMPLICATIONS]"
D DDS^BDMFDIC
Q
CDELETE ;EP;TO DELETE COMPLICATION FROM PATIENT'S COMPLICATION LIST
D REG^BDMFUTIL
Q:$D(BDMQUIT)
D CSEL
I $D(BDMQUIT) K BDMQUIT Q
N BDMX,BDMZ
F BDMJ=1:1 S BDMX=$P(BDMY,",",BDMJ) Q:BDMX="" I $D(BDM("COMP",BDMX)) S BDMCDA=+$G(BDM("COMP",BDMX)) D CD1
Q
CD1 S DA=BDMCDA
S DIK="^ACM(42,"
D DIK^BDMFDIC
;LOOP THROUGH AND RESET AC FOR EACH OF THIS PATIENTS COMPLICATIONS
NEW BDMX,DA,DIK
S BDMX=0 F S BDMX=$O(^ACM(42,"C",DFN,BDMX)) Q:'BDMX D
.S DA=BDMX,DIK="^ACM(42," D IX^DIK K DA,DIK
Q
CLDELETE ;EP;TO DELETE COMPLICATION LIST ENTRY
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K BDMQUIT
D CSEL
I $D(BDMQUIT) K BDMQUIT D BACK Q
N BDMJ,BDMX
F BDMJ=1:1 S BDMX=$P(BDMY,",",BDMJ) Q:BDMX="" I $D(BDM("COMPLICATIONS",BDMX)) D CLD1
D BACK
Q
CLD1 S DA=+$G(BDM("COMPLICATIONS",BDMX))
I $D(^ACM(42,"B",DA)) D Q
.W !!,$P(BDM("COMPLICATIONS",BDMX),U,2)," is being referenced and cannot be deleted."
.H 2
S DIK="^ACM(42.1,"
D DIK^BDMFDIC
Q
CINIT ;EP;INITIALIZE LIST OF PATIENTS COMPLICATIONS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K ^TMP("BDMVR",$J),BDMJ,BDM("TMP")
N A,B,C,X,Y,Z
S X=""
S VALMCNT=0
S X=" Complications"
D Z(X)
S X=" NO. Complication ONSET DATE"
D Z(X)
S X=" --- ------------------------------ ----------"
D Z(X)
S A=0,C=0
F S A=$O(^ACM(42,"C",DFN,A)) Q:'A D
.S Y=$G(^ACM(42,A,0))
.Q:'Y
.Q:$P(Y,U,4)'=BDMRDA
.S C=C+1
.S Y=$G(^ACM(42.1,+Y,0))
.S BDM("TMP",Y,C)=A
S BDMJ=0
S A=""
F S A=$O(BDM("TMP",A)) Q:A="" S C=0 F S C=$O(BDM("TMP",A,C)) Q:C'=+C D
.S BDMJ=BDMJ+1
.S Y=BDM("TMP",A,C)
.S Y=$P($G(^ACM(42,Y,"DT")),U)
.X ^DD("DD")
.S X=""
.S $E(X,5)=BDMJ
.S $E(X,10)=A
.S $E(X,42)=Y
.D Z(X)
.S ONSET=Y
.S BDM("COMP",BDMJ)=BDM("TMP",A,C)
BACK S VALMBCK="R"
Q
COMDISP ;EP;TO DISPLAY AND EDIT CASE COMMENTS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV COMMENTS"
D VALM^BDMVRL(BDMVALM)
Q
COMEDIT ;EP;TO EDIT COMMENTS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
D CLEAR^VALM1
S DA=BDMRPDA
S DIE="^ACM(41,"
S DR=13
D DIE^BDMFDIC
Q
COMINIT ;EP;INITIALIZE LIST OF COMMENTS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K ^TMP("BDMVR",$J)
N X,Y,Z
S VALMCNT=0
S X="Case Comments"
D Z(X)
S X="----------------------------------------"
D Z(X)
S A=0
F S A=$O(^ACM(41,BDMRPDA,1,A)) Q:'A D
.S Y=$G(^ACM(41,BDMRPDA,1,A,0))
.Q:Y=""
.S X=Y
.D Z(X)
D BACK
Q
CSEL ;SELECT COMPLICATION
S DIR(0)="LO^1:"_BDMJ
S DIR("A")="Which Complication(s)"
W !
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMY=Y
Q
DELETE ;EP;TO DELETE A PATIENT FROM CMS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K BDMQUIT
N ACMEP,ACMPTDEL,ACMPP,ACMRGTP,ACMRGTP,ACMQUIT
D CURRENT^ACMED
S (ACMEP,ACMPTDEL,ACMPP,ACMRGTP)=""
S ACMRG=BDMRDA
S ACMRGNA=BDMREGNM
D ^ACMLPAT
D PAUSE^BDMFMENU
Q
DA ;EP;TO DO THE DIABETES AUDIT
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S X="APCLD99"
X ^%ZOSF("TEST")
I $T D Q
.S DIC("B")=BDMREGNM
.D ^APCLD99
S X="APCL DIABETES PROGRAM QA AUDIT"
S DIC="^APCLRPT("
S DIC(0)="FM"
D DIC^BDMFDIC
I Y=-1 D Q
.W !,*7,"DIABETES PROGRAM QA AUDIT REPORT NOT AVAILABLE"
.H 2
S APCL1=+Y
S X="APCL CUMULATIVE DIABETES QA"
S DIC="^APCLRPT("
S DIC(0)="FM"
D DIC^BDMFDIC
S APCL2=$S(Y>0:+Y,1:0)
S APCLDMRG=BDMRDA
D GO^APCLDM
Q
DMMEDS ;EP;TO SELECT DM MED TAXONOMY FOR DISPLAY OF DM MEDS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
N S,T,TX,X,Y,Z,BDM,BDMJ,BDMMEDS
S (T,TX)="DM AUDIT "
F S T=$O(^ATXAX("B",T)) Q:T=""!(T'[TX) D
.S X=0
.F S X=$O(^ATXAX("B",T,X)) Q:'X D
..Q:+$P($G(^ATXAX(X,0)),U,15)'=50
..S BDM(X)=""
S BDMTXDA=0
F S BDMTXDA=$O(BDM(BDMTXDA)) Q:'BDMTXDA D
.S X=0
.F S X=$O(^ATXAX(BDMTXDA,21,X)) Q:'X D
..S Y=$P($G(^ATXAX(BDMTXDA,21,X,0)),U)
..Q:'Y
..S BDMMEDS(Y)=""
Q:'$D(BDMMEDS)
S DA=DFN
D MP1^BDMVRL1
Q
RR ;EP;TO START PRINT OF REGISTER REPORTS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K ACMPRV,ACMSRT,ACMGTP,ACMDM,ACMRG,ACMRGNA,ACMEP,ACMES,ACMPP,ACMPS,ACMPTNA,ACMPC,ACMRGDFN
S ACMRG=BDMRDA
S ACMRGNA=BDMREGNM
S ACMCTRLP="REG;CMP;DX;FM;PROB;CR;CT"
S ACMCTRLS="CMPL;DXL;AD"
D CURRENT^ACMED
D RP^BDMFMENU
S ACMDM=""
Q
COMPLIST ;CREATE COMPLICATIONS LIST ARRAY
K BDM("COMPLIST"),BDM("COMPLICATIONS")
S X=0
F S X=$O(^ACM(42.1,"RG",BDMRDA,X)) Q:'X D
.S Y=$G(^ACM(42.1,X,0))
.Q:Y=""
.S BDM("COMPLIST",$P(Y,U))=X
S BDMJ=0
S Y=""
F S Y=$O(BDM("COMPLIST",Y)) Q:Y="" D
.S BDMJ=BDMJ+1
.S BDM("COMPLICATIONS",BDMJ)=BDM("COMPLIST",Y)_U_Y
Q
CLIST ;LIST ALL COMPLICATIONS
D CLEAR^VALM1
N X,Y,Z
K BDM("COMPLICATIONS"),BDMJ
D COMPLIST
I '$D(BDM("COMPLICATIONS")) D Q
.W !!,"NO COMPLICATIONS TO LIST."
.D PAUSE^BDMFMENU
W !!?5,"NO.",?10,"COMPLICATION"
W !?5,"---",?10,"--------------------"
S X=0
F S X=$O(BDM("COMPLICATIONS",X)) Q:'X D
.W !?5,X,?10,$P(BDM("COMPLICATIONS",X),U,2)
Q
CLINIT ;EP;TO INITIALIZE COMPLICATIONS LIST
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K ^TMP("BDMVR",$J)
K BDM("COMPLIST")
N J,X,Y,Z
D COMPLIST
S VALMCNT=0
S X=" Complications"
D Z(X)
S X=" NO. Complication"
D Z(X)
S X=" --- ------------------------------"
D Z(X)
S A=""
F S A=$O(BDM("COMPLIST",A)) Q:A="" D
.S X=""
.S $E(X,5)=(VALMCNT-2)
.S $E(X,10)=A
.D Z(X)
.S BDM("COMP",VALMCNT-2)=+BDM("COMPLIST",A)
S BDMJ=VALMCNT-3
Q
CLADD ;EP;TO ADD NEW COMPLICATION
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S DIC="^ACM(42.1,"
S DIC(0)="AEMLQZ"
S DIC("A")="Name of New Complication: "
W !
D DIC^BDMFDIC
Q:'+Y
S X=BDMRDA
S (DA,DA(1))=+Y
S DIC="^ACM(42.1,"_DA_",""RG"","
S DIC(0)="L"
S:'$D(^ACM(42.1,DA,"RG",0)) ^ACM(42.1,DA,"RG",0)="^9002242.11P"
D FILE^BDMFDIC
D BACK
Q
CLEDIT ;EP;TO EDIT EXISTING COMPLICATIONS LIST ENTRY
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K BDMQUIT
D CSEL
I $D(BDMQUIT) K BDMQUIT D BACK Q
F BDMI=1:1 S X=$P(BDMY,",",BDMI) Q:X="" I $G(BDM("COMPLICATIONS",X)) D CLE1
D BACK
Q
CLE1 W @IOF
W !,"Edit COMPLICATION NAME:"
S DA=+BDM("COMPLICATIONS",X)
S DIE="^ACM(42.1,"
S DR=".01;1101"
W !
D FULL^VALM1 ;LIST MANAGER
D DIE^BDMFDIC
Q
CL ;EP;FOR COMPLICATIONS LIST FUNCTIONS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV COMPLICATIONS LIST"
D VALM^BDMVRL(BDMVALM)
Q
DL ;EP;FOR DIAGNOSIS LIST FUNCTIONS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV DIAGNOSES LIST"
D VALM^BDMVRL(BDMVALM)
Q
USER ;EP;TO SETUP DMS USER
D REG^BDMFUTIL
Q:$D(BDMQUIT)
F D U1 Q:$D(BDMQUIT)!$D(BDMOUT)
K BDMQUIT,BDMOUT
Q
U1 S DIR(0)="SO^1:Add/Remove DMS Authorized User;2:List Current DMS Authorized Users"
S DIR("A")="Which one"
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
I Y=1 D UNEW Q
I Y=2 D ULIST Q
Q
UNEW ;ADD NEW DMS USER
S DIC="^VA(200,"
S DIC(0)="AEMQZ"
S DIC("A")="Select NEW DMS User: "
W !
D DIC^BDMFDIC
I +Y<1 S BDMQUIT="" Q
S BDMUSER=+Y
S BDMUNAM=$P($G(^VA(200,+Y,0)),U)
I $D(^ACM(41.1,BDMRDA,"AU",+Y)) D AU Q
S (DINUM,X)=+Y
S (DA,DA(1))=BDMRDA
S DIC="^ACM(41.1,"_DA_",""AU"","
S DIC(0)="L"
S:'$D(^ACM(41.1,DA,"AU",0)) ^ACM(41.1,DA,"AU",0)="^9002241.12P"
D FILE^BDMFDIC
S BDMX="BDMZMENU"
S BDMZ=""
D AU11
AU I $D(^ACM(41.1,BDMRDA,"AU",BDMUSER)) D
.W !!,BDMUNAM," is now an Authorized User"
.W !,"of the Diabetes Managment System."
S DIR(0)="YO"
S DIR("A",1)="Do you wish to REMOVE "_BDMUNAM_" as an Authorized User"
S DIR("A")="of the Diabetes Management System"
S DIR("B")="NO"
W !
D DIR^BDMFDIC
I Y=1 D Q
.S DA=BDMUSER
.S DA(1)=BDMRDA
.S DIK="^ACM(41.1,"_DA(1)_",""AU"","
.D DIK^BDMFDIC
.S X=$O(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
.S BDMZ=$O(^VA(200,BDMUSER,51,"B",+X,0))
.I BDMZ D AUR
.Q
S X=$O(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
S BDMZ=$O(^VA(200,BDMUSER,51,"B",+X,0))
S DIR(0)="YO"
S:'BDMZ DIR("A")="Allow "_BDMUNAM
S:BDMZ DIR("A")="Remove "_BDMUNAM_"'s"
S DIR("A")=DIR("A")_" REGISTER MANAGER AUTHORITY"
S DIR("B")="NO"
W !
D DIR^BDMFDIC
I BDMZ,Y D AUR
AU1 F BDMX="BDMZMENU","BDMZ REGISTER MAINTENANCE" D AU11
Q
AUR ;REMOVE KEY
S DA(1)=BDMUSER,DA=BDMZ,DIK="^VA(200,"_DA(1)_",51,"
D ^DIK
Q
AU11 S X=$O(^DIC(19.1,"B",BDMX,0))
S (DIC,DIK)="^VA(200,"_BDMUSER_",51,"
S DIC(0)="L"
S DA(1)=BDMUSER
S:BDMZ DA=$O(^VA(200,BDMUSER,51,"B",+X,0))
S $P(^VA(200,BDMUSER,51,0),U,2)="200.051P"
D FILE^BDMFDIC:'BDMZ
Q
ULIST ;LIST DMS USERS
W:$D(IOF) @IOF
W !?5,"Current DMS Authorized Users",?35,"Manager Authority"
W !?5,"----------------------------",?35,"-----------------"
N BDMX,BDMY,BDMZ
S BDMZ=$O(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
S BDMX=0
F S BDMX=$O(^ACM(41.1,BDMRDA,"AU",BDMX)) Q:'BDMX D
.S BDMY=$P($G(^VA(200,BDMX,0)),U)
.I BDMZ,BDMY]"" S BDMX(BDMY)=$D(^VA(200,BDMX,51,"B",BDMZ))
S BDMX=""
F S BDMX=$O(BDMX(BDMX)) Q:BDMX=""!$D(BDMQUIT) D
.W !?5,BDMX,?35
.W:BDMX(BDMX) "YES"
.I $Y>(IOSL-2) D PAUSE^BDMFMENU W:$D(IOF) @IOF
Q
Z(X) ;SET TMP NODE
S VALMCNT=VALMCNT+1
S ^TMP("BDMVR",$J,VALMCNT,0)=X
Q
PAUSE ;
K DIR
S DIR(0)="E",DIR("A")="Press enter to continue" D ^DIR K DIR
Q
BDMVRL3 ; cmi/anch/maw - VIEW PT RECORD CON'T ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**9,12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
CDISP ;EP;DISPLAY AND EDIT COMPLICATIONS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV COMPLICATIONS"
+4 DO VALM^BDMVRL(BDMVALM)
+5 QUIT
CADD ;EP;TO ADD COMPLICATION
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 WRITE !?5,"ADD Complications for ",$PIECE(BDMPAT0,U)
+4 DO CLIST
+5 IF '$GET(BDMJ)
QUIT
+6 SET DIR(0)="LO^1:"_BDMJ
+7 SET DIR("A")="Which COMPLICATION(S)"
+8 WRITE !
+9 DO DIR^BDMFDIC
+10 IF +Y<1
QUIT
+11 FOR BDMJ=1:1
SET BDMX=$PIECE(BDMY,",",BDMJ)
IF 'BDMX
QUIT
IF $DATA(BDM("COMPLICATIONS",BDMX))
DO CADD1
+12 KILL BDM("COMPLICATIONS")
+13 QUIT
CADD1 ;
+1 SET X=+BDM("COMPLICATIONS",BDMX)
+2 IF $DATA(^ACM(42,"AC",BDMRPDA,DFN,X))
WRITE !!,"Patient already has ",$PIECE(^ACM(42.1,X,0),U)," as a complication. Use Edit or Delete to modify this complication."
DO PAUSE
QUIT
+3 SET DIC="^ACM(42,"
+4 SET DIC(0)="L"
+5 SET DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA
+6 DO FILE^BDMFDIC
+7 ;EDIT COMPLICATION WHEN ADDED
+8 IF +Y<1
QUIT
+9 SET BDMCDA=+Y
+10 DO CE1
+11 QUIT
CEDIT ;EP;TO EDIT COMPLICATION
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 DO CSEL
+4 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+5 NEW BDMX,BDMZ
+6 FOR BDMJ=1:1
SET BDMX=$PIECE(BDMY,",",BDMJ)
IF BDMX=""
QUIT
IF $DATA(BDM("COMP",BDMX))
SET BDMCDA=+$GET(BDM("COMP",BDMX))
DO CE1
+7 QUIT
CE1 SET DA=BDMCDA
+1 SET DIE="^ACM(42,"
+2 SET DR="[BDM COMPLICATIONS]"
+3 DO DDS^BDMFDIC
+4 QUIT
CDELETE ;EP;TO DELETE COMPLICATION FROM PATIENT'S COMPLICATION LIST
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 DO CSEL
+4 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+5 NEW BDMX,BDMZ
+6 FOR BDMJ=1:1
SET BDMX=$PIECE(BDMY,",",BDMJ)
IF BDMX=""
QUIT
IF $DATA(BDM("COMP",BDMX))
SET BDMCDA=+$GET(BDM("COMP",BDMX))
DO CD1
+7 QUIT
CD1 SET DA=BDMCDA
+1 SET DIK="^ACM(42,"
+2 DO DIK^BDMFDIC
+3 ;LOOP THROUGH AND RESET AC FOR EACH OF THIS PATIENTS COMPLICATIONS
+4 NEW BDMX,DA,DIK
+5 SET BDMX=0
FOR
SET BDMX=$ORDER(^ACM(42,"C",DFN,BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+6 SET DA=BDMX
SET DIK="^ACM(42,"
DO IX^DIK
KILL DA,DIK
End DoDot:1
+7 QUIT
CLDELETE ;EP;TO DELETE COMPLICATION LIST ENTRY
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL BDMQUIT
+4 DO CSEL
+5 IF $DATA(BDMQUIT)
KILL BDMQUIT
DO BACK
QUIT
+6 NEW BDMJ,BDMX
+7 FOR BDMJ=1:1
SET BDMX=$PIECE(BDMY,",",BDMJ)
IF BDMX=""
QUIT
IF $DATA(BDM("COMPLICATIONS",BDMX))
DO CLD1
+8 DO BACK
+9 QUIT
CLD1 SET DA=+$GET(BDM("COMPLICATIONS",BDMX))
+1 IF $DATA(^ACM(42,"B",DA))
Begin DoDot:1
+2 WRITE !!,$PIECE(BDM("COMPLICATIONS",BDMX),U,2)," is being referenced and cannot be deleted."
+3 HANG 2
End DoDot:1
QUIT
+4 SET DIK="^ACM(42.1,"
+5 DO DIK^BDMFDIC
+6 QUIT
CINIT ;EP;INITIALIZE LIST OF PATIENTS COMPLICATIONS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL ^TMP("BDMVR",$JOB),BDMJ,BDM("TMP")
+4 NEW A,B,C,X,Y,Z
+5 SET X=""
+6 SET VALMCNT=0
+7 SET X=" Complications"
+8 DO Z(X)
+9 SET X=" NO. Complication ONSET DATE"
+10 DO Z(X)
+11 SET X=" --- ------------------------------ ----------"
+12 DO Z(X)
+13 SET A=0
SET C=0
+14 FOR
SET A=$ORDER(^ACM(42,"C",DFN,A))
IF 'A
QUIT
Begin DoDot:1
+15 SET Y=$GET(^ACM(42,A,0))
+16 IF 'Y
QUIT
+17 IF $PIECE(Y,U,4)'=BDMRDA
QUIT
+18 SET C=C+1
+19 SET Y=$GET(^ACM(42.1,+Y,0))
+20 SET BDM("TMP",Y,C)=A
End DoDot:1
+21 SET BDMJ=0
+22 SET A=""
+23 FOR
SET A=$ORDER(BDM("TMP",A))
IF A=""
QUIT
SET C=0
FOR
SET C=$ORDER(BDM("TMP",A,C))
IF C'=+C
QUIT
Begin DoDot:1
+24 SET BDMJ=BDMJ+1
+25 SET Y=BDM("TMP",A,C)
+26 SET Y=$PIECE($GET(^ACM(42,Y,"DT")),U)
+27 XECUTE ^DD("DD")
+28 SET X=""
+29 SET $EXTRACT(X,5)=BDMJ
+30 SET $EXTRACT(X,10)=A
+31 SET $EXTRACT(X,42)=Y
+32 DO Z(X)
+33 SET ONSET=Y
+34 SET BDM("COMP",BDMJ)=BDM("TMP",A,C)
End DoDot:1
BACK SET VALMBCK="R"
+1 QUIT
COMDISP ;EP;TO DISPLAY AND EDIT CASE COMMENTS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV COMMENTS"
+4 DO VALM^BDMVRL(BDMVALM)
+5 QUIT
COMEDIT ;EP;TO EDIT COMMENTS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 DO CLEAR^VALM1
+4 SET DA=BDMRPDA
+5 SET DIE="^ACM(41,"
+6 SET DR=13
+7 DO DIE^BDMFDIC
+8 QUIT
COMINIT ;EP;INITIALIZE LIST OF COMMENTS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL ^TMP("BDMVR",$JOB)
+4 NEW X,Y,Z
+5 SET VALMCNT=0
+6 SET X="Case Comments"
+7 DO Z(X)
+8 SET X="----------------------------------------"
+9 DO Z(X)
+10 SET A=0
+11 FOR
SET A=$ORDER(^ACM(41,BDMRPDA,1,A))
IF 'A
QUIT
Begin DoDot:1
+12 SET Y=$GET(^ACM(41,BDMRPDA,1,A,0))
+13 IF Y=""
QUIT
+14 SET X=Y
+15 DO Z(X)
End DoDot:1
+16 DO BACK
+17 QUIT
CSEL ;SELECT COMPLICATION
+1 SET DIR(0)="LO^1:"_BDMJ
+2 SET DIR("A")="Which Complication(s)"
+3 WRITE !
+4 DO DIR^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 SET BDMY=Y
+7 QUIT
DELETE ;EP;TO DELETE A PATIENT FROM CMS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL BDMQUIT
+4 NEW ACMEP,ACMPTDEL,ACMPP,ACMRGTP,ACMRGTP,ACMQUIT
+5 DO CURRENT^ACMED
+6 SET (ACMEP,ACMPTDEL,ACMPP,ACMRGTP)=""
+7 SET ACMRG=BDMRDA
+8 SET ACMRGNA=BDMREGNM
+9 DO ^ACMLPAT
+10 DO PAUSE^BDMFMENU
+11 QUIT
DA ;EP;TO DO THE DIABETES AUDIT
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET X="APCLD99"
+4 XECUTE ^%ZOSF("TEST")
+5 IF $TEST
Begin DoDot:1
+6 SET DIC("B")=BDMREGNM
+7 DO ^APCLD99
End DoDot:1
QUIT
+8 SET X="APCL DIABETES PROGRAM QA AUDIT"
+9 SET DIC="^APCLRPT("
+10 SET DIC(0)="FM"
+11 DO DIC^BDMFDIC
+12 IF Y=-1
Begin DoDot:1
+13 WRITE !,*7,"DIABETES PROGRAM QA AUDIT REPORT NOT AVAILABLE"
+14 HANG 2
End DoDot:1
QUIT
+15 SET APCL1=+Y
+16 SET X="APCL CUMULATIVE DIABETES QA"
+17 SET DIC="^APCLRPT("
+18 SET DIC(0)="FM"
+19 DO DIC^BDMFDIC
+20 SET APCL2=$SELECT(Y>0:+Y,1:0)
+21 SET APCLDMRG=BDMRDA
+22 DO GO^APCLDM
+23 QUIT
DMMEDS ;EP;TO SELECT DM MED TAXONOMY FOR DISPLAY OF DM MEDS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 NEW S,T,TX,X,Y,Z,BDM,BDMJ,BDMMEDS
+4 SET (T,TX)="DM AUDIT "
+5 FOR
SET T=$ORDER(^ATXAX("B",T))
IF T=""!(T'[TX)
QUIT
Begin DoDot:1
+6 SET X=0
+7 FOR
SET X=$ORDER(^ATXAX("B",T,X))
IF 'X
QUIT
Begin DoDot:2
+8 IF +$PIECE($GET(^ATXAX(X,0)),U,15)'=50
QUIT
+9 SET BDM(X)=""
End DoDot:2
End DoDot:1
+10 SET BDMTXDA=0
+11 FOR
SET BDMTXDA=$ORDER(BDM(BDMTXDA))
IF 'BDMTXDA
QUIT
Begin DoDot:1
+12 SET X=0
+13 FOR
SET X=$ORDER(^ATXAX(BDMTXDA,21,X))
IF 'X
QUIT
Begin DoDot:2
+14 SET Y=$PIECE($GET(^ATXAX(BDMTXDA,21,X,0)),U)
+15 IF 'Y
QUIT
+16 SET BDMMEDS(Y)=""
End DoDot:2
End DoDot:1
+17 IF '$DATA(BDMMEDS)
QUIT
+18 SET DA=DFN
+19 DO MP1^BDMVRL1
+20 QUIT
RR ;EP;TO START PRINT OF REGISTER REPORTS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL ACMPRV,ACMSRT,ACMGTP,ACMDM,ACMRG,ACMRGNA,ACMEP,ACMES,ACMPP,ACMPS,ACMPTNA,ACMPC,ACMRGDFN
+4 SET ACMRG=BDMRDA
+5 SET ACMRGNA=BDMREGNM
+6 SET ACMCTRLP="REG;CMP;DX;FM;PROB;CR;CT"
+7 SET ACMCTRLS="CMPL;DXL;AD"
+8 DO CURRENT^ACMED
+9 DO RP^BDMFMENU
+10 SET ACMDM=""
+11 QUIT
COMPLIST ;CREATE COMPLICATIONS LIST ARRAY
+1 KILL BDM("COMPLIST"),BDM("COMPLICATIONS")
+2 SET X=0
+3 FOR
SET X=$ORDER(^ACM(42.1,"RG",BDMRDA,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=$GET(^ACM(42.1,X,0))
+5 IF Y=""
QUIT
+6 SET BDM("COMPLIST",$PIECE(Y,U))=X
End DoDot:1
+7 SET BDMJ=0
+8 SET Y=""
+9 FOR
SET Y=$ORDER(BDM("COMPLIST",Y))
IF Y=""
QUIT
Begin DoDot:1
+10 SET BDMJ=BDMJ+1
+11 SET BDM("COMPLICATIONS",BDMJ)=BDM("COMPLIST",Y)_U_Y
End DoDot:1
+12 QUIT
CLIST ;LIST ALL COMPLICATIONS
+1 DO CLEAR^VALM1
+2 NEW X,Y,Z
+3 KILL BDM("COMPLICATIONS"),BDMJ
+4 DO COMPLIST
+5 IF '$DATA(BDM("COMPLICATIONS"))
Begin DoDot:1
+6 WRITE !!,"NO COMPLICATIONS TO LIST."
+7 DO PAUSE^BDMFMENU
End DoDot:1
QUIT
+8 WRITE !!?5,"NO.",?10,"COMPLICATION"
+9 WRITE !?5,"---",?10,"--------------------"
+10 SET X=0
+11 FOR
SET X=$ORDER(BDM("COMPLICATIONS",X))
IF 'X
QUIT
Begin DoDot:1
+12 WRITE !?5,X,?10,$PIECE(BDM("COMPLICATIONS",X),U,2)
End DoDot:1
+13 QUIT
CLINIT ;EP;TO INITIALIZE COMPLICATIONS LIST
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL ^TMP("BDMVR",$JOB)
+4 KILL BDM("COMPLIST")
+5 NEW J,X,Y,Z
+6 DO COMPLIST
+7 SET VALMCNT=0
+8 SET X=" Complications"
+9 DO Z(X)
+10 SET X=" NO. Complication"
+11 DO Z(X)
+12 SET X=" --- ------------------------------"
+13 DO Z(X)
+14 SET A=""
+15 FOR
SET A=$ORDER(BDM("COMPLIST",A))
IF A=""
QUIT
Begin DoDot:1
+16 SET X=""
+17 SET $EXTRACT(X,5)=(VALMCNT-2)
+18 SET $EXTRACT(X,10)=A
+19 DO Z(X)
+20 SET BDM("COMP",VALMCNT-2)=+BDM("COMPLIST",A)
End DoDot:1
+21 SET BDMJ=VALMCNT-3
+22 QUIT
CLADD ;EP;TO ADD NEW COMPLICATION
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET DIC="^ACM(42.1,"
+4 SET DIC(0)="AEMLQZ"
+5 SET DIC("A")="Name of New Complication: "
+6 WRITE !
+7 DO DIC^BDMFDIC
+8 IF '+Y
QUIT
+9 SET X=BDMRDA
+10 SET (DA,DA(1))=+Y
+11 SET DIC="^ACM(42.1,"_DA_",""RG"","
+12 SET DIC(0)="L"
+13 IF '$DATA(^ACM(42.1,DA,"RG",0))
SET ^ACM(42.1,DA,"RG",0)="^9002242.11P"
+14 DO FILE^BDMFDIC
+15 DO BACK
+16 QUIT
CLEDIT ;EP;TO EDIT EXISTING COMPLICATIONS LIST ENTRY
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL BDMQUIT
+4 DO CSEL
+5 IF $DATA(BDMQUIT)
KILL BDMQUIT
DO BACK
QUIT
+6 FOR BDMI=1:1
SET X=$PIECE(BDMY,",",BDMI)
IF X=""
QUIT
IF $GET(BDM("COMPLICATIONS",X))
DO CLE1
+7 DO BACK
+8 QUIT
CLE1 WRITE @IOF
+1 WRITE !,"Edit COMPLICATION NAME:"
+2 SET DA=+BDM("COMPLICATIONS",X)
+3 SET DIE="^ACM(42.1,"
+4 SET DR=".01;1101"
+5 WRITE !
+6 ;LIST MANAGER
DO FULL^VALM1
+7 DO DIE^BDMFDIC
+8 QUIT
CL ;EP;FOR COMPLICATIONS LIST FUNCTIONS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV COMPLICATIONS LIST"
+4 DO VALM^BDMVRL(BDMVALM)
+5 QUIT
DL ;EP;FOR DIAGNOSIS LIST FUNCTIONS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV DIAGNOSES LIST"
+4 DO VALM^BDMVRL(BDMVALM)
+5 QUIT
USER ;EP;TO SETUP DMS USER
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 FOR
DO U1
IF $DATA(BDMQUIT)!$DATA(BDMOUT)
QUIT
+4 KILL BDMQUIT,BDMOUT
+5 QUIT
U1 SET DIR(0)="SO^1:Add/Remove DMS Authorized User;2:List Current DMS Authorized Users"
+1 SET DIR("A")="Which one"
+2 DO DIR^BDMFDIC
+3 IF Y<1
SET BDMQUIT=""
QUIT
+4 IF Y=1
DO UNEW
QUIT
+5 IF Y=2
DO ULIST
QUIT
+6 QUIT
UNEW ;ADD NEW DMS USER
+1 SET DIC="^VA(200,"
+2 SET DIC(0)="AEMQZ"
+3 SET DIC("A")="Select NEW DMS User: "
+4 WRITE !
+5 DO DIC^BDMFDIC
+6 IF +Y<1
SET BDMQUIT=""
QUIT
+7 SET BDMUSER=+Y
+8 SET BDMUNAM=$PIECE($GET(^VA(200,+Y,0)),U)
+9 IF $DATA(^ACM(41.1,BDMRDA,"AU",+Y))
DO AU
QUIT
+10 SET (DINUM,X)=+Y
+11 SET (DA,DA(1))=BDMRDA
+12 SET DIC="^ACM(41.1,"_DA_",""AU"","
+13 SET DIC(0)="L"
+14 IF '$DATA(^ACM(41.1,DA,"AU",0))
SET ^ACM(41.1,DA,"AU",0)="^9002241.12P"
+15 DO FILE^BDMFDIC
+16 SET BDMX="BDMZMENU"
+17 SET BDMZ=""
+18 DO AU11
AU IF $DATA(^ACM(41.1,BDMRDA,"AU",BDMUSER))
Begin DoDot:1
+1 WRITE !!,BDMUNAM," is now an Authorized User"
+2 WRITE !,"of the Diabetes Managment System."
End DoDot:1
+3 SET DIR(0)="YO"
+4 SET DIR("A",1)="Do you wish to REMOVE "_BDMUNAM_" as an Authorized User"
+5 SET DIR("A")="of the Diabetes Management System"
+6 SET DIR("B")="NO"
+7 WRITE !
+8 DO DIR^BDMFDIC
+9 IF Y=1
Begin DoDot:1
+10 SET DA=BDMUSER
+11 SET DA(1)=BDMRDA
+12 SET DIK="^ACM(41.1,"_DA(1)_",""AU"","
+13 DO DIK^BDMFDIC
+14 SET X=$ORDER(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
+15 SET BDMZ=$ORDER(^VA(200,BDMUSER,51,"B",+X,0))
+16 IF BDMZ
DO AUR
+17 QUIT
End DoDot:1
QUIT
+18 SET X=$ORDER(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
+19 SET BDMZ=$ORDER(^VA(200,BDMUSER,51,"B",+X,0))
+20 SET DIR(0)="YO"
+21 IF 'BDMZ
SET DIR("A")="Allow "_BDMUNAM
+22 IF BDMZ
SET DIR("A")="Remove "_BDMUNAM_"'s"
+23 SET DIR("A")=DIR("A")_" REGISTER MANAGER AUTHORITY"
+24 SET DIR("B")="NO"
+25 WRITE !
+26 DO DIR^BDMFDIC
+27 IF BDMZ
IF Y
DO AUR
AU1 FOR BDMX="BDMZMENU","BDMZ REGISTER MAINTENANCE"
DO AU11
+1 QUIT
AUR ;REMOVE KEY
+1 SET DA(1)=BDMUSER
SET DA=BDMZ
SET DIK="^VA(200,"_DA(1)_",51,"
+2 DO ^DIK
+3 QUIT
AU11 SET X=$ORDER(^DIC(19.1,"B",BDMX,0))
+1 SET (DIC,DIK)="^VA(200,"_BDMUSER_",51,"
+2 SET DIC(0)="L"
+3 SET DA(1)=BDMUSER
+4 IF BDMZ
SET DA=$ORDER(^VA(200,BDMUSER,51,"B",+X,0))
+5 SET $PIECE(^VA(200,BDMUSER,51,0),U,2)="200.051P"
+6 IF 'BDMZ
DO FILE^BDMFDIC
+7 QUIT
ULIST ;LIST DMS USERS
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !?5,"Current DMS Authorized Users",?35,"Manager Authority"
+3 WRITE !?5,"----------------------------",?35,"-----------------"
+4 NEW BDMX,BDMY,BDMZ
+5 SET BDMZ=$ORDER(^DIC(19.1,"B","BDMZ REGISTER MAINTENANCE",0))
+6 SET BDMX=0
+7 FOR
SET BDMX=$ORDER(^ACM(41.1,BDMRDA,"AU",BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+8 SET BDMY=$PIECE($GET(^VA(200,BDMX,0)),U)
+9 IF BDMZ
IF BDMY]""
SET BDMX(BDMY)=$DATA(^VA(200,BDMX,51,"B",BDMZ))
End DoDot:1
+10 SET BDMX=""
+11 FOR
SET BDMX=$ORDER(BDMX(BDMX))
IF BDMX=""!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+12 WRITE !?5,BDMX,?35
+13 IF BDMX(BDMX)
WRITE "YES"
+14 IF $Y>(IOSL-2)
DO PAUSE^BDMFMENU
IF $DATA(IOF)
WRITE @IOF
End DoDot:1
+15 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("BDMVR",$JOB,VALMCNT,0)=X
+3 QUIT
PAUSE ;
+1 KILL DIR
+2 SET DIR(0)="E"
SET DIR("A")="Press enter to continue"
DO ^DIR
KILL DIR
+3 QUIT
