BDMVRL8 ; cmi/anch/maw - VIEW PT RECORD & DIAGNOSIS DATA ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
;
;
CDISP ;EP;DISPLAY AND EDIT DIAGNOSIS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV DIAGNOSIS"
D VALM^BDMVRL(BDMVALM)
Q
CADD ;EP;TO ADD DIAGNOSIS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
W !?5,"ADD Diagnosis for ",$P(BDMPAT0,U)
D CLIST
Q:'$G(BDMJ)
S DIR(0)="LO^1:"_BDMJ
S DIR("A")="Which DIAGNOSIS(S)"
W !
D DIR^BDMFDIC
Q:+Y<1
B F BDMJ=1:1 S BDMX=$P(BDMY,",",BDMJ) Q:'BDMX D CADD1:$D(BDM("DIAG",BDMX))
K BDM("DIAG")
Q
CADD1 ;
S X=+BDM("DIAG",BDMX)
I $D(^ACM(44,"AC",BDMRPDA,DFN,X)) W !!,"Patient already has ",$P(^ACM(44.1,X,0),U)," as a diagnosis. Use Edit or Delete to modify this diagnosis" D PAUSE Q
S DIC="^ACM(44,"
S DIC(0)="L"
S DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA
D FILE^BDMFDIC
Q:+Y<1
S BDMCDA=+Y
D CE1
Q
CEDIT ;EP;TO EDIT DIAGNOSIS
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("DIAG",BDMX)) S BDMCDA=+$G(BDM("DIAG",BDMX)) D CE1
Q
CE1 S DA=BDMCDA
S DIE="^ACM(44,"
S DR="[BDM DIAGNOSIS]"
D DDS^BDMFDIC
Q
CDELETE ;EP;TO DELETE DIAGNOSIS FROM PATIENT'S DIAGNOSIS 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("DIAG",BDMX)) S BDMCDA=+$G(BDM("DIAG",BDMX)) D CD1
Q
CD1 S DA=BDMCDA
S DIK="^ACM(44,"
D DIK^BDMFDIC
NEW BDMX,DA,DIK
S BDMX=0 F S BDMX=$O(^ACM(44,"C",DFN,BDMX)) Q:'BDMX D
.S DA=BDMX,DIK="^ACM(44," D IX^DIK K DA,DIK
Q
CLDELETE ;EP;TO DELETE DIAGNOSIS 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("DIAG",BDMX)) D CLD1
D BACK
Q
CLD1 S DA=+$G(BDM("DIAG",BDMX))
I $D(^ACM(44,"B",DA)) D Q
.W !!,$P(BDM("DIAG",BDMX),U,2)," is being referenced and cannot be deleted."
.H 2
S DIK="^ACM(44.1,"
D DIK^BDMFDIC
Q
CINIT ;EP;INITIALIZE LIST OF PATIENTS DIAGNOSIS
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
;DISPLAY PROBLEM LIST FROM PCC
S X="DIABETES RELATED PROBLEMS ON THE PROBLEM LIST"
D Z(X)
S X="PROB #",$E(X,9)="DX",$E(X,20)="PROVIDER NARRATIVE",$E(X,57)="DATE OF ONSET",$E(X,72)="STATUS"
D Z(X)
S X="",$P(X,"-",80)=""
D Z(X)
N J,X,Y,Z,F,N
K BDMPLDX
D GETPLDX
I '$D(BDMPLDX) S X="None on file" D Z(X)
I $O(BDMPLDX(0)) D
.S J=0 F S J=$O(BDMPLDX(J)) Q:J'=+J D
..S F=$$VALI^XBDIQ1(9000011,J,.06)
..S N=$$VAL^XBDIQ1(9000011,J,.07)
..S X=$S($P(^AUTTLOC(F,0),U,7)]"":$J($P(^(0),U,7),4),1:"??")_N
..S $E(X,9)=$$VAL^XBDIQ1(9000011,J,.01)
..S $E(X,20)=$E($$VAL^XBDIQ1(9000011,J,.05),1,35)
..S $E(X,57)=$$VAL^XBDIQ1(9000011,J,.13)
..S $E(X,72)=$$VAL^XBDIQ1(9000011,J,.12)
..D Z(X)
S X=" "
D Z(X)
S X=" Register Diagnosis"
D Z(X)
S X=" NO. Diagnosis ONSET DATE"
D Z(X)
S X=" --- ------------------------------ ----------"
D Z(X)
S A=0,C=0
F S A=$O(^ACM(44,"C",DFN,A)) Q:'A D
.S Y=$G(^ACM(44,A,0))
.Q:'Y
.Q:$P(Y,U,4)'=BDMRDA
.S C=C+1
.S Y=$G(^ACM(44.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(44,Y,"SV")),U,2)
.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("DIAG",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 DIAGNOSIS
S DIR(0)="LO^1:"_BDMJ
S DIR("A")="Which Diagnosis(s)"
W !
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMY=Y
Q
DIAGLIST ;CREATE DIAGNOSIS LIST ARRAY
K BDM("DIAGLIST"),BDM("DIAG")
S X=0
F S X=$O(^ACM(44.1,"RG",BDMRDA,X)) Q:'X D
.S Y=$G(^ACM(44.1,X,0))
.Q:Y=""
.S BDM("DIAGLIST",$P(Y,U))=X
S BDMJ=0
S Y=""
F S Y=$O(BDM("DIAGLIST",Y)) Q:Y="" D
.S BDMJ=BDMJ+1
.S BDM("DIAG",BDMJ)=BDM("DIAGLIST",Y)_U_Y
Q
CLIST ;LIST ALL DIAGNOSIS
D CLEAR^VALM1
N X,Y,Z
K BDM("DIAG"),BDMJ
D DIAGLIST
I '$D(BDM("DIAG")) D Q
.W !!,"NO DIAGNOSIS TO LIST."
.D PAUSE^BDMFMENU
W !!?5,"NO.",?10,"DIAG"
W !?5,"---",?10,"--------------------"
S X=0
F S X=$O(BDM("DIAG",X)) Q:'X D
.W !?5,X,?10,$P(BDM("DIAG",X),U,2)
Q
GETPLDX ;
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",DFN,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D" ;deleted problem
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^BDMUTL(I,$P(^ATXAX(T,0),U),9) S BDMPLDX(X)="" Q
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL(2019,"PXRM DIABETES",$P(^AUPNPROB(X,800),U,1)) S BDMPLDX(X)=""
.Q
Q
;
CLINIT ;EP;TO INITIALIZE DIAGNOSIS LIST
D REG^BDMFUTIL
Q:$D(BDMQUIT)
K ^TMP("BDMVR",$J)
K BDM("DIAGLIST")
D DIAGLIST
S VALMCNT=0
S X=" Diagnosis"
D Z(X)
S X=" NO. Diagnosis"
D Z(X)
S X=" --- ------------------------------"
D Z(X)
S A=""
F S A=$O(BDM("DIAGLIST",A)) Q:A="" D
.S X=""
.S $E(X,5)=(VALMCNT-2)
.S $E(X,10)=A
.D Z(X)
.S BDM("DIAG",VALMCNT-2)=+BDM("DIAGLIST",A)
S BDMJ=VALMCNT-3
Q
CLADD ;EP;TO ADD NEW DIAGNOSIS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S DIC="^ACM(44.1,"
S DIC(0)="AEMLQZ"
S DIC("A")="Name of New Diagnosis: "
W !
D DIC^BDMFDIC
Q:'+Y
S X=BDMRDA
S (DA,DA(1))=+Y
S DIC="^ACM(44.1,"_DA_",""RG"","
S DIC(0)="L"
S:'$D(^ACM(44.1,DA,"RG",0)) ^ACM(44.1,DA,"RG",0)="^9002244.11P"
D FILE^BDMFDIC
D BACK
Q
CLEDIT ;EP;TO EDIT EXISTING DIAGNOSIS 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("DIAG",X)) D CLE1
D BACK
Q
CLE1 W @IOF
W !,"Edit DIAGNOSIS NAME:"
S DA=+BDM("DIAG",X)
S DIE="^ACM(44.1,"
S DR=".01;1101"
W !
D FULL^VALM1
D DIE^BDMFDIC
Q
CL ;EP;FOR DIAGNOSIS LIST FUNCTIONS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
S BDMVALM="BDMV DIAGNOSIS 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
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
HDR ;
S VALMSG=$$VALMSG^BDMVU
K VALMHDR
;
S VALMHDR(1)="Make sure that the date of onset is also documented on the"
S VALMHDR(2)="patient's problem list so other clinician's can see it."
S VALMHDR(3)="Problem list entries can be modified using EHR."
Q
BDMVRL8 ; cmi/anch/maw - VIEW PT RECORD & DIAGNOSIS DATA ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**12**;JUN 14, 2007;Build 51
+2 ;
+3 ;
CDISP ;EP;DISPLAY AND EDIT DIAGNOSIS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV DIAGNOSIS"
+4 DO VALM^BDMVRL(BDMVALM)
+5 QUIT
CADD ;EP;TO ADD DIAGNOSIS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 WRITE !?5,"ADD Diagnosis for ",$PIECE(BDMPAT0,U)
+4 DO CLIST
+5 IF '$GET(BDMJ)
QUIT
+6 SET DIR(0)="LO^1:"_BDMJ
+7 SET DIR("A")="Which DIAGNOSIS(S)"
+8 WRITE !
+9 DO DIR^BDMFDIC
+10 IF +Y<1
QUIT
B FOR BDMJ=1:1
SET BDMX=$PIECE(BDMY,",",BDMJ)
IF 'BDMX
QUIT
IF $DATA(BDM("DIAG",BDMX))
DO CADD1
+1 KILL BDM("DIAG")
+2 QUIT
CADD1 ;
+1 SET X=+BDM("DIAG",BDMX)
+2 IF $DATA(^ACM(44,"AC",BDMRPDA,DFN,X))
WRITE !!,"Patient already has ",$PIECE(^ACM(44.1,X,0),U)," as a diagnosis. Use Edit or Delete to modify this diagnosis"
DO PAUSE
QUIT
+3 SET DIC="^ACM(44,"
+4 SET DIC(0)="L"
+5 SET DIC("DR")=".02////"_DFN_";.03////"_BDMRPDA_";.04////"_BDMRDA
+6 DO FILE^BDMFDIC
+7 IF +Y<1
QUIT
+8 SET BDMCDA=+Y
+9 DO CE1
+10 QUIT
CEDIT ;EP;TO EDIT DIAGNOSIS
+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("DIAG",BDMX))
SET BDMCDA=+$GET(BDM("DIAG",BDMX))
DO CE1
+7 QUIT
CE1 SET DA=BDMCDA
+1 SET DIE="^ACM(44,"
+2 SET DR="[BDM DIAGNOSIS]"
+3 DO DDS^BDMFDIC
+4 QUIT
CDELETE ;EP;TO DELETE DIAGNOSIS FROM PATIENT'S DIAGNOSIS 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("DIAG",BDMX))
SET BDMCDA=+$GET(BDM("DIAG",BDMX))
DO CD1
+7 QUIT
CD1 SET DA=BDMCDA
+1 SET DIK="^ACM(44,"
+2 DO DIK^BDMFDIC
+3 NEW BDMX,DA,DIK
+4 SET BDMX=0
FOR
SET BDMX=$ORDER(^ACM(44,"C",DFN,BDMX))
IF 'BDMX
QUIT
Begin DoDot:1
+5 SET DA=BDMX
SET DIK="^ACM(44,"
DO IX^DIK
KILL DA,DIK
End DoDot:1
+6 QUIT
CLDELETE ;EP;TO DELETE DIAGNOSIS 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("DIAG",BDMX))
DO CLD1
+8 DO BACK
+9 QUIT
CLD1 SET DA=+$GET(BDM("DIAG",BDMX))
+1 IF $DATA(^ACM(44,"B",DA))
Begin DoDot:1
+2 WRITE !!,$PIECE(BDM("DIAG",BDMX),U,2)," is being referenced and cannot be deleted."
+3 HANG 2
End DoDot:1
QUIT
+4 SET DIK="^ACM(44.1,"
+5 DO DIK^BDMFDIC
+6 QUIT
CINIT ;EP;INITIALIZE LIST OF PATIENTS DIAGNOSIS
+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 ;DISPLAY PROBLEM LIST FROM PCC
+8 SET X="DIABETES RELATED PROBLEMS ON THE PROBLEM LIST"
+9 DO Z(X)
+10 SET X="PROB #"
SET $EXTRACT(X,9)="DX"
SET $EXTRACT(X,20)="PROVIDER NARRATIVE"
SET $EXTRACT(X,57)="DATE OF ONSET"
SET $EXTRACT(X,72)="STATUS"
+11 DO Z(X)
+12 SET X=""
SET $PIECE(X,"-",80)=""
+13 DO Z(X)
+14 NEW J,X,Y,Z,F,N
+15 KILL BDMPLDX
+16 DO GETPLDX
+17 IF '$DATA(BDMPLDX)
SET X="None on file"
DO Z(X)
+18 IF $ORDER(BDMPLDX(0))
Begin DoDot:1
+19 SET J=0
FOR
SET J=$ORDER(BDMPLDX(J))
IF J'=+J
QUIT
Begin DoDot:2
+20 SET F=$$VALI^XBDIQ1(9000011,J,.06)
+21 SET N=$$VAL^XBDIQ1(9000011,J,.07)
+22 SET X=$SELECT($PIECE(^AUTTLOC(F,0),U,7)]"":$JUSTIFY($PIECE(^(0),U,7),4),1:"??")_N
+23 SET $EXTRACT(X,9)=$$VAL^XBDIQ1(9000011,J,.01)
+24 SET $EXTRACT(X,20)=$EXTRACT($$VAL^XBDIQ1(9000011,J,.05),1,35)
+25 SET $EXTRACT(X,57)=$$VAL^XBDIQ1(9000011,J,.13)
+26 SET $EXTRACT(X,72)=$$VAL^XBDIQ1(9000011,J,.12)
+27 DO Z(X)
End DoDot:2
End DoDot:1
+28 SET X=" "
+29 DO Z(X)
+30 SET X=" Register Diagnosis"
+31 DO Z(X)
+32 SET X=" NO. Diagnosis ONSET DATE"
+33 DO Z(X)
+34 SET X=" --- ------------------------------ ----------"
+35 DO Z(X)
+36 SET A=0
SET C=0
+37 FOR
SET A=$ORDER(^ACM(44,"C",DFN,A))
IF 'A
QUIT
Begin DoDot:1
+38 SET Y=$GET(^ACM(44,A,0))
+39 IF 'Y
QUIT
+40 IF $PIECE(Y,U,4)'=BDMRDA
QUIT
+41 SET C=C+1
+42 SET Y=$GET(^ACM(44.1,+Y,0))
+43 SET BDM("TMP",Y,C)=A
End DoDot:1
+44 SET BDMJ=0
+45 SET A=""
+46 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
+47 SET BDMJ=BDMJ+1
+48 SET Y=BDM("TMP",A,C)
+49 SET Y=$PIECE($GET(^ACM(44,Y,"SV")),U,2)
+50 XECUTE ^DD("DD")
+51 SET X=""
+52 SET $EXTRACT(X,5)=BDMJ
+53 SET $EXTRACT(X,10)=A
+54 SET $EXTRACT(X,42)=Y
+55 DO Z(X)
+56 SET ONSET=Y
+57 SET BDM("DIAG",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 DIAGNOSIS
+1 SET DIR(0)="LO^1:"_BDMJ
+2 SET DIR("A")="Which Diagnosis(s)"
+3 WRITE !
+4 DO DIR^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 SET BDMY=Y
+7 QUIT
DIAGLIST ;CREATE DIAGNOSIS LIST ARRAY
+1 KILL BDM("DIAGLIST"),BDM("DIAG")
+2 SET X=0
+3 FOR
SET X=$ORDER(^ACM(44.1,"RG",BDMRDA,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=$GET(^ACM(44.1,X,0))
+5 IF Y=""
QUIT
+6 SET BDM("DIAGLIST",$PIECE(Y,U))=X
End DoDot:1
+7 SET BDMJ=0
+8 SET Y=""
+9 FOR
SET Y=$ORDER(BDM("DIAGLIST",Y))
IF Y=""
QUIT
Begin DoDot:1
+10 SET BDMJ=BDMJ+1
+11 SET BDM("DIAG",BDMJ)=BDM("DIAGLIST",Y)_U_Y
End DoDot:1
+12 QUIT
CLIST ;LIST ALL DIAGNOSIS
+1 DO CLEAR^VALM1
+2 NEW X,Y,Z
+3 KILL BDM("DIAG"),BDMJ
+4 DO DIAGLIST
+5 IF '$DATA(BDM("DIAG"))
Begin DoDot:1
+6 WRITE !!,"NO DIAGNOSIS TO LIST."
+7 DO PAUSE^BDMFMENU
End DoDot:1
QUIT
+8 WRITE !!?5,"NO.",?10,"DIAG"
+9 WRITE !?5,"---",?10,"--------------------"
+10 SET X=0
+11 FOR
SET X=$ORDER(BDM("DIAG",X))
IF 'X
QUIT
Begin DoDot:1
+12 WRITE !?5,X,?10,$PIECE(BDM("DIAG",X),U,2)
End DoDot:1
+13 QUIT
GETPLDX ;
+1 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+2 IF 'T
QUIT
+3 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",DFN,X))
IF X'=+X
QUIT
Begin DoDot:1
+4 ;deleted problem
IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 SET I=$PIECE(^AUPNPROB(X,0),U)
+6 IF $$ICD^BDMUTL(I,$PIECE(^ATXAX(T,0),U),9)
SET BDMPLDX(X)=""
QUIT
+7 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL(2019,"PXRM DIABETES",$PIECE(^AUPNPROB(X,800),U,1))
SET BDMPLDX(X)=""
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
CLINIT ;EP;TO INITIALIZE DIAGNOSIS LIST
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 KILL ^TMP("BDMVR",$JOB)
+4 KILL BDM("DIAGLIST")
+5 DO DIAGLIST
+6 SET VALMCNT=0
+7 SET X=" Diagnosis"
+8 DO Z(X)
+9 SET X=" NO. Diagnosis"
+10 DO Z(X)
+11 SET X=" --- ------------------------------"
+12 DO Z(X)
+13 SET A=""
+14 FOR
SET A=$ORDER(BDM("DIAGLIST",A))
IF A=""
QUIT
Begin DoDot:1
+15 SET X=""
+16 SET $EXTRACT(X,5)=(VALMCNT-2)
+17 SET $EXTRACT(X,10)=A
+18 DO Z(X)
+19 SET BDM("DIAG",VALMCNT-2)=+BDM("DIAGLIST",A)
End DoDot:1
+20 SET BDMJ=VALMCNT-3
+21 QUIT
CLADD ;EP;TO ADD NEW DIAGNOSIS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET DIC="^ACM(44.1,"
+4 SET DIC(0)="AEMLQZ"
+5 SET DIC("A")="Name of New Diagnosis: "
+6 WRITE !
+7 DO DIC^BDMFDIC
+8 IF '+Y
QUIT
+9 SET X=BDMRDA
+10 SET (DA,DA(1))=+Y
+11 SET DIC="^ACM(44.1,"_DA_",""RG"","
+12 SET DIC(0)="L"
+13 IF '$DATA(^ACM(44.1,DA,"RG",0))
SET ^ACM(44.1,DA,"RG",0)="^9002244.11P"
+14 DO FILE^BDMFDIC
+15 DO BACK
+16 QUIT
CLEDIT ;EP;TO EDIT EXISTING DIAGNOSIS 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("DIAG",X))
DO CLE1
+7 DO BACK
+8 QUIT
CLE1 WRITE @IOF
+1 WRITE !,"Edit DIAGNOSIS NAME:"
+2 SET DA=+BDM("DIAG",X)
+3 SET DIE="^ACM(44.1,"
+4 SET DR=".01;1101"
+5 WRITE !
+6 DO FULL^VALM1
+7 DO DIE^BDMFDIC
+8 QUIT
CL ;EP;FOR DIAGNOSIS LIST FUNCTIONS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 SET BDMVALM="BDMV DIAGNOSIS 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
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
HDR ;
+1 SET VALMSG=$$VALMSG^BDMVU
+2 KILL VALMHDR
+3 ;
+4 SET VALMHDR(1)="Make sure that the date of onset is also documented on the"
+5 SET VALMHDR(2)="patient's problem list so other clinician's can see it."
+6 SET VALMHDR(3)="Problem list entries can be modified using EHR."
+7 QUIT
