BDMLET ; IHS/CMI/LAB - VIEW PT RECORD LT ; 05 Dec 2016 2:14 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,4,5,10**;JUN 14, 2007;Build 12
;Education Text Inserts to the Letter
;Education Followup Text Insert
;
;
;cmi/maw 7/31/2007 PATCH 1 added item 25 and code CENTER to allow centering of text
;
;
EN S BDMVALM="BDM LETTER"
D VALM^BDMVRL(BDMVALM)
Q
EXIT K BDMQUIT,BDMOUT,BDMLDA
K ^TMP("BDMVR",$J)
Q
ADD ;EP;TO ADD DMS LETTERS
D EXIT
D A1
D E11:$G(BDMLDA)
Q
A1 D CLEAR^VALM1
K BDMLDA
S:$G(DIC(0))="" DIC(0)="AELMQZ"
S DIC="^BDMLET("
S DIC("A")="NAME OF LETTER: "
S:DIC(0)["L" DIC("DR")=".02////"_DUZ_";.03////"_DT,DLAYGO=9003201
W !?16,"------------------------------"
D DIC^BDMFDIC
S:+Y>0 BDMLDA=+Y
BACK S VALMBCK="R"
Q
WHICH ;EP;TO IDENTIFY WHICH LETTER TO USE
S DIC(0)="AEMQZ"
D A1
Q
SELECT ;EP;TO SELECT DMS LETTER
K BDMQUIT,BDMOUT
D LIST
S1 S DIR(0)="NO^1:"_BDMJ
S DIR("A")="Select LETTER NO."
W !
D DIR^BDMFDIC
I +Y<1!'$G(BDMTMP(+Y)) S BDMQUIT="" Q
S BDMLDA=+BDMTMP(+Y)
Q
EDIT ;EP;TO EDIT DMS LETTER
D EXIT
D S1
I $D(BDMQUIT) K BDMQUIT D BACK Q
E11 D CLEAR^VALM1
S DA=BDMLDA
S DIE="^BDMLET("
S DR=1
D DIE^BDMFDIC
D PARSE
D BACK
Q
EPPRINT ;EP;TO PRINT LETTER FROM XBNEW CALL
S BDM("STATUS")=BDMLSTAT
D PRINT
Q
PRINT ;EP;TO PRINT DMS LETTER
Q:'$G(BDMLDA)!'$G(DFN)
D CLEAR^VALM1:IO=IO(0)&(IOST["C-")
W @IOF
N A,B,C,D,X,Y,Z
S X=0
F S X=$O(^BDMLET(BDMLDA,1,X)) Q:'X D
.S Y=$G(^BDMLET(BDMLDA,1,X,0))
.I Y["|" D INTP
.W !,Y
D PAUSE^BDMFMENU
Q
INTP ;INTERPRET VARIABLES
N ZZ,ZZZ,X,K,E,M
S X=Y
X ^%ZOSF("UPPERCASE")
S ZZ=Y
S ZZZ=$P(Y,"|")
F I=2:2 S J=$P(Y,"|",I) Q:J="" D
.S E=$O(^BDMLETI("B",J,0))
.I 'E S E=$O(^BDMLETI("B",$E(J,1,8),0))
.I 'E Q
.S M=$G(^BDMLETI(E,1))
.I M="" Q
.X M ;THE mumps code must set Z equal to the value
.;K is the mumps code to execute
.;S K=$E($P(J," "),1,8)
.;I $T(@K)="" S ZZ="" Q
.;D @K
.S ZZ=$P(ZZ,("|"_J_"|"))_Z_$P(ZZ,("|"_J_"|"),2)
S Y=ZZ
Q
INTPF ;EP;TO ENTER EDUCATION TEXT WITH FOLLOWUP ITEM
N ZZ,ZZZ,X,K
Q:BDMZ=""
Q:BDMZ["OTHER"
Q:BDMZ["LDL"
Q:BDMZ["HDL"
Q:BDMZ["CHOL"
Q:BDMZ["DEPR"
Q:BDMZ["EKG"
Q:BDMZ["GFR"
W !
I BDMZ["FOOT" S X="FOOT EXAM EDUCATION"
I BDMZ["DENTAL" S X="DENTAL EXAM EDUCATION"
I BDMZ["EYE" S X="EYE EXAM EDUCATION"
I BDMZ["FLU" S X="FLU SHOT EDUCATION"
I BDMZ["PNEUMO" S X="PNEUMO EDUCATION"
I BDMZ["HEP" S X="HEP B EDUCATION"
I BDMZ["TD" S X="TETANUS EDUCATION"
I BDMZ["PPD" S X="TB TEST EDUCATION"
I BDMZ["A1C" S X="A1C HEMOGLOBIN EDUCATION"
I BDMZ["CREATIN" S X="CREATININE EDUCATION"
I BDMZ["URINE" S X="URINE PROTEIN TEST EDUCATION"
I BDMZ["LIPID" S X="LIPID PANEL EDUCATION"
I BDMZ["TRIG" S X="LIPID PANEL EDUCATION"
I BDMZ["NUTRI" S X="NUTRITION EDUCATION"
I BDMZ["PHYSCIAL" S X="PHYSICAL ACTIVITY EDUCATION"
I BDMZ["A/C" S X="A/C RATIO EDUCATION"
S Y=$O(^BDMLETI("B",X,0))
D EDUCP
Q
;
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT DMS LETTER
S (ZTRTN,BDMRTN)="PRINT^BDMLET"
S ZTDESC="PRINT DMS PATIENT LETTER"
S ZTSAVE("BDM*")=""
S ZTSAVE("DFN")=""
D ^BDMFZIS
Q
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT DMS LETTER
Q
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
N X
K ^TMP("BDMVR",$J),BDMJ
S VALMCNT=0
K X
;S $E(X,5)="NO. LETTER"
;D Z(X)
;K X
;S $E(X,5)="--- ------------------------------"
;D Z(X)
S BDMJ=0
S Y=""
F S Y=$O(^BDMLET("B",Y)) Q:Y="" D
.S Z=0
.F S Z=$O(^BDMLET("B",Y,Z)) Q:'Z D
..S BDMJ=BDMJ+1
..K X
..S $E(X,5)=BDMJ
..S $E(X,10)=Y
..D Z(X)
..S BDMTMP(BDMJ)=Z
Q
INSERT ;EP;TO LIST INSERT ITEMS
S BDMVALM="BDM LETTER ITEMS"
D TERM^VALM0
D CLEAR^VALM1
D EN^VALM(BDMVALM)
D CLEAR^VALM1
D BACK
Q
IHDR ;
S VALMHDR(1)="NO. INSERT"
;S $E(VALMHDR(2),"-",78)=""
Q
ILIST ;LIST ITEM TEXT
K BDMLETI
N X,C,Y
S (X,C)=0
F S X=$O(^BDMLETI("C",X)) Q:X'=+X D
.S Y=0 F S Y=$O(^BDMLETI("C",X,Y)) Q:Y'=+Y D
..S C=C+1
..S BDMLETI(C,0)=C,$E(BDMLETI(C,0),10)=$P(^BDMLETI(Y,0),U,1)
..S BDMLETI("IDX",C,C)=Y
S (VALMCNT,BDMLETIC)=C
Q
PARSE ;DIVIDE UP THE LETTER CONTENT
N I,J,K,X,Y,Z,ZZ,BDMTMP
S (Z,ZZ)=""
S (J,X)=0
F S X=$O(^BDMLET(BDMLDA,1,X)) Q:'X D
.S Y=$G(^BDMLET(BDMLDA,1,X,0))
.Q:Y=""
.I Y["|" D VARS
.D LINE
Q:'$D(BDMTMP)
S %X="BDMTMP("
S %Y="^BDMLET("_BDMLDA_",1,"
D %XY^%RCR
Q
VARS ;CONVERT VARIABLES
N I,J,K,X,Z,E
;S ZZ="ZL BDMLET S X=""I""_J,X=$T(@X)"
F I=2:2 S J=$P(Y,"|",I) Q:J="" D:J
.;X ZZ
.S E=$O(^BDMLETI("C",J,0))
.;S Z=$P(X,";;",3)
.S X=$P(^BDMLETI(E,0),U,1)
.S Y=$P(Y,("|"_J_"|"))_"|"_X_"|"_$P(Y,("|"_J_"|"),2)
Q
LINE ;
I $L(Y)<81 D Q
.S J=J+1
.S BDMTMP(J,0)=Y
F I=1:1 S K=$P(Y," ",I) Q:$P(Y," ",I,99)="" D
.I $L(Z_" "_K)>80 D Q
..S J=J+1
..S BDMTMP(J,0)=Z
..S Z=""
.I Z="" S Z=K
.E S Z=Z_" "_K
I $L(Z) S J=J+1,BDMTMP(J,0)=Z
Q
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
D SELECT
Q:'$G(BDMLDA)
D ZIS
Q
LIST ;LIST LETTERS
K BDMTMP
N BDM,BDMX,BDMY,BDMZ
W @IOF
W !!?5,"DMS letters currently on file:"
W !!,"NO. LETTER"
W ?27,"NO. LETTER"
W ?54,"NO. LETTER"
W !,"--- --------------------"
W ?27,"--- --------------------"
W ?54,"--- --------------------"
S BDMJ=0
S BDM=""
F S BDM=$O(^BDMLET("B",BDM)) Q:BDM="" D
.S BDMX=0
.F S BDMX=$O(^BDMLET("B",BDM,BDMX)) Q:'BDMX D
..S BDMY=$G(^BDMLET(BDMX,0))
..Q:BDMY=""
..S BDMJ=BDMJ+1
..S BDMTMP(BDMJ)=BDMX_U_BDM
..W:BDMJ#3=1 !
..W:BDMJ#3=2 ?27
..W:BDMJ#3=0 ?53
..W $J(BDMJ,2)," "
..W $E(BDM,1,20)
Q
CHART ;EP;TO PRINT PATIENT CHART NUMBER
S Z="CHART NO.: "_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
Q
EDUCATE ;EP - to print all education
S Z=""
NEW Y,X,E
S E=0 F S E=$O(^BDMLETI("C",E)) Q:E'=+E D
.S Y=0 F S Y=$O(^BDMLETI("C",E,Y)) Q:Y'=+Y D
..Q:'$P(^BDMLETI(Y,0),U,3)
..D EDUCP
..Q
.Q
Q
EDUCP ;EP - print education text
S Z=""
Q:'Y
NEW X
S X=0 F S X=$O(^BDMLETI(Y,2,X)) Q:X'=+X W !,^BDMLETI(Y,2,X,0)
W !
Q
ADDRESS ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
S Z=$G(^DPT(DFN,.11))
W !
W:$G(ZZZ)]"" ?$L(ZZZ)
W $P(Z,U)
I $P(Z,U,2) D
.W !
.W:$G(ZZZ)]"" ?$L(ZZZ)
.W $P(Z,U,2)
I $P(Z,U,3) D
.W !
.W:$G(ZZZ)]"" ?$L(ZZZ)
.W $P(Z,U,3)
W !
W:$G(ZZZ)]"" ?$L(ZZZ)
W $P(Z,U,4),", ",$P($G(^DIC(5,+$P(Z,U,5),0)),U,2)," ",$P(Z,U,6)
S (Z,ZZ)=""
Q
;
CENTER ;-- try and center the text here
;
N T,L,N,I
S Z=""
S T=$P(X,"|",3)
S L=$L(T)/2
S N=(80/2)-L
F I=1:1:N S Z=Z_" "
Q
;
FOLLOW ;EP;TO PRINT FOLLOW-UP MESSAGE
S BDM("STATUS")=$E($G(BDM("STATUS")))
S BDMPDA=DFN
D SSET^BDMVRL42
N BDMX
S BDMX=0
F S BDMX=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX)) Q:'BDMX!$D(BDMQUIT) D
.S BDMY=""
.F S BDMY=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY)) Q:BDMY=""!$D(BDMQUIT) D
..S BDMZ=$G(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY))
..W !?5,BDMY,?28,"----------",?40,$P(BDMZ,U)
S (Z,ZZ)=""
Q
;
TEXT ;FOLLOWUP LETTER WITH EDUCATION INSERTS;
S BDM("STATUS")=$E($G(BDM("STATUS")))
S BDMPDA=DFN
D SSET^BDMVRL42
N BDMX
S BDMX=0
F S BDMX=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX)) Q:'BDMX!$D(BDMQUIT) D
.S BDMY=""
.F S BDMY=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY)) Q:BDMY=""!$D(BDMQUIT) D
..S BDMZ=$G(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY))
..W !?5,BDMY,?28,"----------",?40,$P(BDMZ,U)
..D INTPF
S (Z,ZZ)=""
Q
;
REGISTER ;EP;TO PRINT PROVIDER NAME IN A LETTER
S BDMRPDA=$G(^ACM(41,"AC",DFN,BDMRDA))
I 'BDMRPDA S Z="" Q
S Z=$P($G(^ACM(41,BDMRPDA,"DT")),U,15)
I Z="" Q
S Z=$P($G(^VA(200,Z,0)),U)
S Z=$P($P(Z,",",2)," ")_" "_$P(Z,",")
Q
DELETE ;DELETE LETTER
D S1
I $D(BDMQUIT) K BDMQUIT D BACK Q
S DA=BDMLDA
S DIK="^BDMLET("
D ^DIK
D BACK
Q
Z(X) ;SET TMP NODE
S VALMCNT=VALMCNT+1
S ^TMP("BDMVR",$J,VALMCNT,0)=X
Q
PRIMARY ;EP;TO PRINT PCP PROVIDER NAME IN A LETTER
K R
D ALLDP^BDPAPI(DFN,"DESIGNATED PRIMARY PROVIDER",.R)
S Z=$P($G(R("DESIGNATED PRIMARY PROVIDER")),U,1)
I Z]"" S Z=$P($P(Z,",",2)," ")_" "_$P(Z,",")
Q
PHARTEXT ;FOLLOWUP LETTER WITH EDUCATION INSERTS; NOEL PHARES, NOT EDUCATION OR DEP SCR
S BDM("STATUS")=$E($G(BDM("STATUS")))
S BDMPDA=DFN
D SSET^BDMVRL42
N BDMX
S BDMX=0
F S BDMX=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX)) Q:'BDMX!$D(BDMQUIT) D
.S BDMY=""
.F S BDMY=$O(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY)) Q:BDMY=""!$D(BDMQUIT) D
..Q:BDMY="DEPRESSION SCR"
..Q:BDMY="NUTRITION ED"
..Q:BDMY="EXERCISE ED"
..Q:BDMY="OTHER ED"
..S BDMZ=$G(^TMP("BDMTMP",$J,"FUL",DFN,BDMX,BDMY))
..W !?5,BDMY,?28,"----------",?40,$P(BDMZ,U)
..D INTPFP
S (Z,ZZ)=""
Q
;
INTPFP ;EP;TO ENTER EDUCATION TEXT WITH FOLLOWUP ITEM
N ZZ,ZZZ,X,K
Q:BDMZ=""
Q:BDMZ["OTHER"
Q:BDMZ["LDL"
Q:BDMZ["HDL"
Q:BDMZ["CHOL"
Q:BDMZ["DEPR"
;Q:BDMZ["EKG"
;Q:BDMZ["GFR"
W !
I BDMZ["FOOT" S X="FOOT EXAM EDUCATION"
I BDMZ["DENTAL" S X="DENTAL EXAM EDUCATION"
I BDMZ["EYE" S X="EYE EXAM EDUCATION"
I BDMZ["FLU" S X="FLU SHOT EDUCATION"
I BDMZ["PNEUMO" S X="PNEUMO EDUCATION"
I BDMZ["HEP" S X="HEP B EDUCATION"
I BDMZ["TD" S X="TETANUS EDUCATION"
I BDMZ["PPD" S X="TB TEST EDUCATION"
I BDMZ["A1C" S X="A1C HEMOGLOBIN EDUCATION"
I BDMZ["CREATIN" S X="CREATININE EDUCATION"
I BDMZ["URINE" S X="URINE PROTEIN TEST EDUCATION"
I BDMZ["LIPID" S X="LIPID PANEL EDUCATION"
I BDMZ["TRIG" S X="LIPID PANEL EDUCATION"
I BDMZ["NUTRI" S X="NUTRITION EDUCATION"
I BDMZ["PHYSICAL" S X="PHYSICAL ACTIVITY EDUCATION"
I BDMZ["A/C" S X="A/C RATIO EDUCATION"
I BDMZ["EKG" S X="EKG"
I BDMZ["GFR" S X="eGFR"
S Y=$O(^BDMLETI("B",X,0))
D EDUCP
Q
BDMLET ; IHS/CMI/LAB - VIEW PT RECORD LT ; 05 Dec 2016 2:14 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,4,5,10**;JUN 14, 2007;Build 12
+2 ;Education Text Inserts to the Letter
+3 ;Education Followup Text Insert
+4 ;
+5 ;
+6 ;cmi/maw 7/31/2007 PATCH 1 added item 25 and code CENTER to allow centering of text
+7 ;
+8 ;
EN SET BDMVALM="BDM LETTER"
+1 DO VALM^BDMVRL(BDMVALM)
+2 QUIT
EXIT KILL BDMQUIT,BDMOUT,BDMLDA
+1 KILL ^TMP("BDMVR",$JOB)
+2 QUIT
ADD ;EP;TO ADD DMS LETTERS
+1 DO EXIT
+2 DO A1
+3 IF $GET(BDMLDA)
DO E11
+4 QUIT
A1 DO CLEAR^VALM1
+1 KILL BDMLDA
+2 IF $GET(DIC(0))=""
SET DIC(0)="AELMQZ"
+3 SET DIC="^BDMLET("
+4 SET DIC("A")="NAME OF LETTER: "
+5 IF DIC(0)["L"
SET DIC("DR")=".02////"_DUZ_";.03////"_DT
SET DLAYGO=9003201
+6 WRITE !?16,"------------------------------"
+7 DO DIC^BDMFDIC
+8 IF +Y>0
SET BDMLDA=+Y
BACK SET VALMBCK="R"
+1 QUIT
WHICH ;EP;TO IDENTIFY WHICH LETTER TO USE
+1 SET DIC(0)="AEMQZ"
+2 DO A1
+3 QUIT
SELECT ;EP;TO SELECT DMS LETTER
+1 KILL BDMQUIT,BDMOUT
+2 DO LIST
S1 SET DIR(0)="NO^1:"_BDMJ
+1 SET DIR("A")="Select LETTER NO."
+2 WRITE !
+3 DO DIR^BDMFDIC
+4 IF +Y<1!'$GET(BDMTMP(+Y))
SET BDMQUIT=""
QUIT
+5 SET BDMLDA=+BDMTMP(+Y)
+6 QUIT
EDIT ;EP;TO EDIT DMS LETTER
+1 DO EXIT
+2 DO S1
+3 IF $DATA(BDMQUIT)
KILL BDMQUIT
DO BACK
QUIT
E11 DO CLEAR^VALM1
+1 SET DA=BDMLDA
+2 SET DIE="^BDMLET("
+3 SET DR=1
+4 DO DIE^BDMFDIC
+5 DO PARSE
+6 DO BACK
+7 QUIT
EPPRINT ;EP;TO PRINT LETTER FROM XBNEW CALL
+1 SET BDM("STATUS")=BDMLSTAT
+2 DO PRINT
+3 QUIT
PRINT ;EP;TO PRINT DMS LETTER
+1 IF '$GET(BDMLDA)!'$GET(DFN)
QUIT
+2 IF IO=IO(0)&(IOST["C-")
DO CLEAR^VALM1
+3 WRITE @IOF
+4 NEW A,B,C,D,X,Y,Z
+5 SET X=0
+6 FOR
SET X=$ORDER(^BDMLET(BDMLDA,1,X))
IF 'X
QUIT
Begin DoDot:1
+7 SET Y=$GET(^BDMLET(BDMLDA,1,X,0))
+8 IF Y["|"
DO INTP
+9 WRITE !,Y
End DoDot:1
+10 DO PAUSE^BDMFMENU
+11 QUIT
INTP ;INTERPRET VARIABLES
+1 NEW ZZ,ZZZ,X,K,E,M
+2 SET X=Y
+3 XECUTE ^%ZOSF("UPPERCASE")
+4 SET ZZ=Y
+5 SET ZZZ=$PIECE(Y,"|")
+6 FOR I=2:2
SET J=$PIECE(Y,"|",I)
IF J=""
QUIT
Begin DoDot:1
+7 SET E=$ORDER(^BDMLETI("B",J,0))
+8 IF 'E
SET E=$ORDER(^BDMLETI("B",$EXTRACT(J,1,8),0))
+9 IF 'E
QUIT
+10 SET M=$GET(^BDMLETI(E,1))
+11 IF M=""
QUIT
+12 ;THE mumps code must set Z equal to the value
XECUTE M
+13 ;K is the mumps code to execute
+14 ;S K=$E($P(J," "),1,8)
+15 ;I $T(@K)="" S ZZ="" Q
+16 ;D @K
+17 SET ZZ=$PIECE(ZZ,("|"_J_"|"))_Z_$PIECE(ZZ,("|"_J_"|"),2)
End DoDot:1
+18 SET Y=ZZ
+19 QUIT
INTPF ;EP;TO ENTER EDUCATION TEXT WITH FOLLOWUP ITEM
+1 NEW ZZ,ZZZ,X,K
+2 IF BDMZ=""
QUIT
+3 IF BDMZ["OTHER"
QUIT
+4 IF BDMZ["LDL"
QUIT
+5 IF BDMZ["HDL"
QUIT
+6 IF BDMZ["CHOL"
QUIT
+7 IF BDMZ["DEPR"
QUIT
+8 IF BDMZ["EKG"
QUIT
+9 IF BDMZ["GFR"
QUIT
+10 WRITE !
+11 IF BDMZ["FOOT"
SET X="FOOT EXAM EDUCATION"
+12 IF BDMZ["DENTAL"
SET X="DENTAL EXAM EDUCATION"
+13 IF BDMZ["EYE"
SET X="EYE EXAM EDUCATION"
+14 IF BDMZ["FLU"
SET X="FLU SHOT EDUCATION"
+15 IF BDMZ["PNEUMO"
SET X="PNEUMO EDUCATION"
+16 IF BDMZ["HEP"
SET X="HEP B EDUCATION"
+17 IF BDMZ["TD"
SET X="TETANUS EDUCATION"
+18 IF BDMZ["PPD"
SET X="TB TEST EDUCATION"
+19 IF BDMZ["A1C"
SET X="A1C HEMOGLOBIN EDUCATION"
+20 IF BDMZ["CREATIN"
SET X="CREATININE EDUCATION"
+21 IF BDMZ["URINE"
SET X="URINE PROTEIN TEST EDUCATION"
+22 IF BDMZ["LIPID"
SET X="LIPID PANEL EDUCATION"
+23 IF BDMZ["TRIG"
SET X="LIPID PANEL EDUCATION"
+24 IF BDMZ["NUTRI"
SET X="NUTRITION EDUCATION"
+25 IF BDMZ["PHYSCIAL"
SET X="PHYSICAL ACTIVITY EDUCATION"
+26 IF BDMZ["A/C"
SET X="A/C RATIO EDUCATION"
+27 SET Y=$ORDER(^BDMLETI("B",X,0))
+28 DO EDUCP
+29 QUIT
+30 ;
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT DMS LETTER
+1 SET (ZTRTN,BDMRTN)="PRINT^BDMLET"
+2 SET ZTDESC="PRINT DMS PATIENT LETTER"
+3 SET ZTSAVE("BDM*")=""
+4 SET ZTSAVE("DFN")=""
+5 DO ^BDMFZIS
+6 QUIT
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT DMS LETTER
+1 QUIT
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
+1 NEW X
+2 KILL ^TMP("BDMVR",$JOB),BDMJ
+3 SET VALMCNT=0
+4 KILL X
+5 ;S $E(X,5)="NO. LETTER"
+6 ;D Z(X)
+7 ;K X
+8 ;S $E(X,5)="--- ------------------------------"
+9 ;D Z(X)
+10 SET BDMJ=0
+11 SET Y=""
+12 FOR
SET Y=$ORDER(^BDMLET("B",Y))
IF Y=""
QUIT
Begin DoDot:1
+13 SET Z=0
+14 FOR
SET Z=$ORDER(^BDMLET("B",Y,Z))
IF 'Z
QUIT
Begin DoDot:2
+15 SET BDMJ=BDMJ+1
+16 KILL X
+17 SET $EXTRACT(X,5)=BDMJ
+18 SET $EXTRACT(X,10)=Y
+19 DO Z(X)
+20 SET BDMTMP(BDMJ)=Z
End DoDot:2
End DoDot:1
+21 QUIT
INSERT ;EP;TO LIST INSERT ITEMS
+1 SET BDMVALM="BDM LETTER ITEMS"
+2 DO TERM^VALM0
+3 DO CLEAR^VALM1
+4 DO EN^VALM(BDMVALM)
+5 DO CLEAR^VALM1
+6 DO BACK
+7 QUIT
IHDR ;
+1 SET VALMHDR(1)="NO. INSERT"
+2 ;S $E(VALMHDR(2),"-",78)=""
+3 QUIT
ILIST ;LIST ITEM TEXT
+1 KILL BDMLETI
+2 NEW X,C,Y
+3 SET (X,C)=0
+4 FOR
SET X=$ORDER(^BDMLETI("C",X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET Y=0
FOR
SET Y=$ORDER(^BDMLETI("C",X,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+6 SET C=C+1
+7 SET BDMLETI(C,0)=C
SET $EXTRACT(BDMLETI(C,0),10)=$PIECE(^BDMLETI(Y,0),U,1)
+8 SET BDMLETI("IDX",C,C)=Y
End DoDot:2
End DoDot:1
+9 SET (VALMCNT,BDMLETIC)=C
+10 QUIT
PARSE ;DIVIDE UP THE LETTER CONTENT
+1 NEW I,J,K,X,Y,Z,ZZ,BDMTMP
+2 SET (Z,ZZ)=""
+3 SET (J,X)=0
+4 FOR
SET X=$ORDER(^BDMLET(BDMLDA,1,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$GET(^BDMLET(BDMLDA,1,X,0))
+6 IF Y=""
QUIT
+7 IF Y["|"
DO VARS
+8 DO LINE
End DoDot:1
+9 IF '$DATA(BDMTMP)
QUIT
+10 SET %X="BDMTMP("
+11 SET %Y="^BDMLET("_BDMLDA_",1,"
+12 DO %XY^%RCR
+13 QUIT
VARS ;CONVERT VARIABLES
+1 NEW I,J,K,X,Z,E
+2 ;S ZZ="ZL BDMLET S X=""I""_J,X=$T(@X)"
+3 FOR I=2:2
SET J=$PIECE(Y,"|",I)
IF J=""
QUIT
IF J
Begin DoDot:1
+4 ;X ZZ
+5 SET E=$ORDER(^BDMLETI("C",J,0))
+6 ;S Z=$P(X,";;",3)
+7 SET X=$PIECE(^BDMLETI(E,0),U,1)
+8 SET Y=$PIECE(Y,("|"_J_"|"))_"|"_X_"|"_$PIECE(Y,("|"_J_"|"),2)
End DoDot:1
+9 QUIT
LINE ;
+1 IF $LENGTH(Y)<81
Begin DoDot:1
+2 SET J=J+1
+3 SET BDMTMP(J,0)=Y
End DoDot:1
QUIT
+4 FOR I=1:1
SET K=$PIECE(Y," ",I)
IF $PIECE(Y," ",I,99)=""
QUIT
Begin DoDot:1
+5 IF $LENGTH(Z_" "_K)>80
Begin DoDot:2
+6 SET J=J+1
+7 SET BDMTMP(J,0)=Z
+8 SET Z=""
End DoDot:2
QUIT
+9 IF Z=""
SET Z=K
+10 IF '$TEST
SET Z=Z_" "_K
End DoDot:1
+11 IF $LENGTH(Z)
SET J=J+1
SET BDMTMP(J,0)=Z
+12 QUIT
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
+1 DO SELECT
+2 IF '$GET(BDMLDA)
QUIT
+3 DO ZIS
+4 QUIT
LIST ;LIST LETTERS
+1 KILL BDMTMP
+2 NEW BDM,BDMX,BDMY,BDMZ
+3 WRITE @IOF
+4 WRITE !!?5,"DMS letters currently on file:"
+5 WRITE !!,"NO. LETTER"
+6 WRITE ?27,"NO. LETTER"
+7 WRITE ?54,"NO. LETTER"
+8 WRITE !,"--- --------------------"
+9 WRITE ?27,"--- --------------------"
+10 WRITE ?54,"--- --------------------"
+11 SET BDMJ=0
+12 SET BDM=""
+13 FOR
SET BDM=$ORDER(^BDMLET("B",BDM))
IF BDM=""
QUIT
Begin DoDot:1
+14 SET BDMX=0
+15 FOR
SET BDMX=$ORDER(^BDMLET("B",BDM,BDMX))
IF 'BDMX
QUIT
Begin DoDot:2
+16 SET BDMY=$GET(^BDMLET(BDMX,0))
+17 IF BDMY=""
QUIT
+18 SET BDMJ=BDMJ+1
+19 SET BDMTMP(BDMJ)=BDMX_U_BDM
+20 IF BDMJ#3=1
WRITE !
+21 IF BDMJ#3=2
WRITE ?27
+22 IF BDMJ#3=0
WRITE ?53
+23 WRITE $JUSTIFY(BDMJ,2)," "
+24 WRITE $EXTRACT(BDM,1,20)
End DoDot:2
End DoDot:1
+25 QUIT
CHART ;EP;TO PRINT PATIENT CHART NUMBER
+1 SET Z="CHART NO.: "_$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+2 QUIT
EDUCATE ;EP - to print all education
+1 SET Z=""
+2 NEW Y,X,E
+3 SET E=0
FOR
SET E=$ORDER(^BDMLETI("C",E))
IF E'=+E
QUIT
Begin DoDot:1
+4 SET Y=0
FOR
SET Y=$ORDER(^BDMLETI("C",E,Y))
IF Y'=+Y
QUIT
Begin DoDot:2
+5 IF '$PIECE(^BDMLETI(Y,0),U,3)
QUIT
+6 DO EDUCP
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 QUIT
EDUCP ;EP - print education text
+1 SET Z=""
+2 IF 'Y
QUIT
+3 NEW X
+4 SET X=0
FOR
SET X=$ORDER(^BDMLETI(Y,2,X))
IF X'=+X
QUIT
WRITE !,^BDMLETI(Y,2,X,0)
+5 WRITE !
+6 QUIT
ADDRESS ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
+1 SET Z=$GET(^DPT(DFN,.11))
+2 WRITE !
+3 IF $GET(ZZZ)]""
WRITE ?$LENGTH(ZZZ)
+4 WRITE $PIECE(Z,U)
+5 IF $PIECE(Z,U,2)
Begin DoDot:1
+6 WRITE !
+7 IF $GET(ZZZ)]""
WRITE ?$LENGTH(ZZZ)
+8 WRITE $PIECE(Z,U,2)
End DoDot:1
+9 IF $PIECE(Z,U,3)
Begin DoDot:1
+10 WRITE !
+11 IF $GET(ZZZ)]""
WRITE ?$LENGTH(ZZZ)
+12 WRITE $PIECE(Z,U,3)
End DoDot:1
+13 WRITE !
+14 IF $GET(ZZZ)]""
WRITE ?$LENGTH(ZZZ)
+15 WRITE $PIECE(Z,U,4),", ",$PIECE($GET(^DIC(5,+$PIECE(Z,U,5),0)),U,2)," ",$PIECE(Z,U,6)
+16 SET (Z,ZZ)=""
+17 QUIT
+18 ;
CENTER ;-- try and center the text here
+1 ;
+2 NEW T,L,N,I
+3 SET Z=""
+4 SET T=$PIECE(X,"|",3)
+5 SET L=$LENGTH(T)/2
+6 SET N=(80/2)-L
+7 FOR I=1:1:N
SET Z=Z_" "
+8 QUIT
+9 ;
FOLLOW ;EP;TO PRINT FOLLOW-UP MESSAGE
+1 SET BDM("STATUS")=$EXTRACT($GET(BDM("STATUS")))
+2 SET BDMPDA=DFN
+3 DO SSET^BDMVRL42
+4 NEW BDMX
+5 SET BDMX=0
+6 FOR
SET BDMX=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX))
IF 'BDMX!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+7 SET BDMY=""
+8 FOR
SET BDMY=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
IF BDMY=""!$DATA(BDMQUIT)
QUIT
Begin DoDot:2
+9 SET BDMZ=$GET(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
+10 WRITE !?5,BDMY,?28,"----------",?40,$PIECE(BDMZ,U)
End DoDot:2
End DoDot:1
+11 SET (Z,ZZ)=""
+12 QUIT
+13 ;
TEXT ;FOLLOWUP LETTER WITH EDUCATION INSERTS;
+1 SET BDM("STATUS")=$EXTRACT($GET(BDM("STATUS")))
+2 SET BDMPDA=DFN
+3 DO SSET^BDMVRL42
+4 NEW BDMX
+5 SET BDMX=0
+6 FOR
SET BDMX=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX))
IF 'BDMX!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+7 SET BDMY=""
+8 FOR
SET BDMY=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
IF BDMY=""!$DATA(BDMQUIT)
QUIT
Begin DoDot:2
+9 SET BDMZ=$GET(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
+10 WRITE !?5,BDMY,?28,"----------",?40,$PIECE(BDMZ,U)
+11 DO INTPF
End DoDot:2
End DoDot:1
+12 SET (Z,ZZ)=""
+13 QUIT
+14 ;
REGISTER ;EP;TO PRINT PROVIDER NAME IN A LETTER
+1 SET BDMRPDA=$GET(^ACM(41,"AC",DFN,BDMRDA))
+2 IF 'BDMRPDA
SET Z=""
QUIT
+3 SET Z=$PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,15)
+4 IF Z=""
QUIT
+5 SET Z=$PIECE($GET(^VA(200,Z,0)),U)
+6 SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+7 QUIT
DELETE ;DELETE LETTER
+1 DO S1
+2 IF $DATA(BDMQUIT)
KILL BDMQUIT
DO BACK
QUIT
+3 SET DA=BDMLDA
+4 SET DIK="^BDMLET("
+5 DO ^DIK
+6 DO BACK
+7 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("BDMVR",$JOB,VALMCNT,0)=X
+3 QUIT
PRIMARY ;EP;TO PRINT PCP PROVIDER NAME IN A LETTER
+1 KILL R
+2 DO ALLDP^BDPAPI(DFN,"DESIGNATED PRIMARY PROVIDER",.R)
+3 SET Z=$PIECE($GET(R("DESIGNATED PRIMARY PROVIDER")),U,1)
+4 IF Z]""
SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+5 QUIT
PHARTEXT ;FOLLOWUP LETTER WITH EDUCATION INSERTS; NOEL PHARES, NOT EDUCATION OR DEP SCR
+1 SET BDM("STATUS")=$EXTRACT($GET(BDM("STATUS")))
+2 SET BDMPDA=DFN
+3 DO SSET^BDMVRL42
+4 NEW BDMX
+5 SET BDMX=0
+6 FOR
SET BDMX=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX))
IF 'BDMX!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+7 SET BDMY=""
+8 FOR
SET BDMY=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
IF BDMY=""!$DATA(BDMQUIT)
QUIT
Begin DoDot:2
+9 IF BDMY="DEPRESSION SCR"
QUIT
+10 IF BDMY="NUTRITION ED"
QUIT
+11 IF BDMY="EXERCISE ED"
QUIT
+12 IF BDMY="OTHER ED"
QUIT
+13 SET BDMZ=$GET(^TMP("BDMTMP",$JOB,"FUL",DFN,BDMX,BDMY))
+14 WRITE !?5,BDMY,?28,"----------",?40,$PIECE(BDMZ,U)
+15 DO INTPFP
End DoDot:2
End DoDot:1
+16 SET (Z,ZZ)=""
+17 QUIT
+18 ;
INTPFP ;EP;TO ENTER EDUCATION TEXT WITH FOLLOWUP ITEM
+1 NEW ZZ,ZZZ,X,K
+2 IF BDMZ=""
QUIT
+3 IF BDMZ["OTHER"
QUIT
+4 IF BDMZ["LDL"
QUIT
+5 IF BDMZ["HDL"
QUIT
+6 IF BDMZ["CHOL"
QUIT
+7 IF BDMZ["DEPR"
QUIT
+8 ;Q:BDMZ["EKG"
+9 ;Q:BDMZ["GFR"
+10 WRITE !
+11 IF BDMZ["FOOT"
SET X="FOOT EXAM EDUCATION"
+12 IF BDMZ["DENTAL"
SET X="DENTAL EXAM EDUCATION"
+13 IF BDMZ["EYE"
SET X="EYE EXAM EDUCATION"
+14 IF BDMZ["FLU"
SET X="FLU SHOT EDUCATION"
+15 IF BDMZ["PNEUMO"
SET X="PNEUMO EDUCATION"
+16 IF BDMZ["HEP"
SET X="HEP B EDUCATION"
+17 IF BDMZ["TD"
SET X="TETANUS EDUCATION"
+18 IF BDMZ["PPD"
SET X="TB TEST EDUCATION"
+19 IF BDMZ["A1C"
SET X="A1C HEMOGLOBIN EDUCATION"
+20 IF BDMZ["CREATIN"
SET X="CREATININE EDUCATION"
+21 IF BDMZ["URINE"
SET X="URINE PROTEIN TEST EDUCATION"
+22 IF BDMZ["LIPID"
SET X="LIPID PANEL EDUCATION"
+23 IF BDMZ["TRIG"
SET X="LIPID PANEL EDUCATION"
+24 IF BDMZ["NUTRI"
SET X="NUTRITION EDUCATION"
+25 IF BDMZ["PHYSICAL"
SET X="PHYSICAL ACTIVITY EDUCATION"
+26 IF BDMZ["A/C"
SET X="A/C RATIO EDUCATION"
+27 IF BDMZ["EKG"
SET X="EKG"
+28 IF BDMZ["GFR"
SET X="eGFR"
+29 SET Y=$ORDER(^BDMLETI("B",X,0))
+30 DO EDUCP
+31 QUIT
