BDMLET.m

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=""