BDMLLT ; IHS/CMI/LAB - VIEW PT RECORD LT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,10**;JUN 14, 2007;Build 12
;
EXIT ;
D EN^XBVK("BDML")
K ^TMP($J,"BDMLLTVR")
K ^XTMP("BDMLLT",BDMJOB,BDMBTH)
K BDMJOB,BDMBTH
Q
SELECT ;EP;TO SELECT BDMLLT LETTER
K BDMLLTQT,BDMLLTOT
D LIST
S1 S DIR(0)="NO^1:"_BDMLLTJ
S DIR("A")="Select LETTER NO."
W !
D DIR^BDMLLTD
I +Y<1!'$G(BDMLLTTP(+Y)) S BDMLLTQT="" Q
S BDMLDA=+BDMLLTTP(+Y)
Q
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT BDMLLT LETTER
S:$G(BDMLRTN)="" (ZTRTN,BDMLRTN)="PRINT^BDMLLT"
S ZTDESC="PRINT BDMLLT PATIENT LETTER"
S ZTSAVE("ACM*")=""
S ZTSAVE("DFN")=""
S ZTSAVE("BDM")=""
D ^BDMLLTZ
Q
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT BDMLLT LETTER
Q
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
N X
K ^TMP($J,"BDMLLTVR"),BDMLLTJ
S VALMCNT=0
K X
S $E(X,5)="NO. LETTER"
D Z(X)
K X
S $E(X,5)="--- ------------------------------"
D Z(X)
S BDMLLTJ=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 BDMLLTJ=BDMLLTJ+1
..K X
..S $E(X,5)=BDMLLTJ
..S $E(X,10)=Y
..D Z(X)
..S BDMLLTTP(BDMLLTJ)=Z
Q
LINE ;
I $L(Y)<81 D Q
.S J=J+1
.S BDMLLTTP(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 BDMLLTTP(J,0)=Z
..S Z=""
.I Z="" S Z=K
.E S Z=Z_" "_K
I $L(Z) S J=J+1,BDMLLTTP(J,0)=Z
Q
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
D SELECT
Q:'$G(BDMLDA)
S BDMLLTJB=$H_$J
D ZIS
Q
LIST ;LIST LETTERS
K BDMLLTTP
N BDML,BDMLLTX,BDMLLTY,BDMLLTZ
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 BDMLLTJ=0
S BDML=""
F S BDML=$O(^BDMLET("B",BDML)) Q:BDML="" D
.S BDMLLTX=0
.F S BDMLLTX=$O(^BDMLET("B",BDML,BDMLLTX)) Q:'BDMLLTX D
..S BDMLLTY=$G(^BDMLET(BDMLLTX,0))
..Q:BDMLLTY=""
..I $G(BDMLREG),$P(BDMLLTY,U,4)'=BDMLREG Q
..S BDMLLTJ=BDMLLTJ+1
..S BDMLLTTP(BDMLLTJ)=BDMLLTX_U_BDML
..W:BDMLLTJ#3=1 !
..W:BDMLLTJ#3=2 ?27
..W:BDMLLTJ#3=0 ?53
..W $J(BDMLLTJ,2)," "
..W $E(BDML,1,20)
Q
Z(X) ;SET TMP NODE
S VALMCNT=VALMCNT+1
S ^TMP($J,"BDMLLTVR",VALMCNT,0)=X
Q
DATE ;EP;TO PRINT LETTER DATE
N Y
S Y=DT
X ^DD("DD")
S Z=Y
Q
COHORT ;EP;TO ESTABLISH COHORT OF PATIENTS TO PRINT
S BDMJOB=$J,BDMBTH=$H
D SELECT
Q:'$G(BDMLDA)
D C1
Q:$D(BDMLLTQT)
S BDMLBROW=""
Q:'$D(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB))
S BDMLRTN="CPRINT^BDMLLT"
D ZIS
K BDMLBROW,BDMJOB,BDMBTH,BDMLLTJB
Q
C1 K ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER")
S BDMLLTJB=$H_$J
N DIR
S DIR(0)="SO^1:Individual Patient(s);2:Search Template of Patients;3:Members of a Case Management Register"
S DIR("A")="Create list for letters by"
D ^DIR
K DIR
I 'Y S BDMLLTQT="" Q
I Y=1 D PATIENT
I Y=2 D TEMPLATE
I Y=3 D REGISTER K BDMLREG
I '$D(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER")) W !!,"No patients selected." D PAUSE Q
Q
PATIENT ;SELECT INDIVIDUAL PATIENTS TO PRINT LETTER
K BDMLLTQT
F D P1 Q:$D(BDMLLTQT)
K BDMLLTQT
S BDMLSTAT="Z"
Q
P1 ;
N DIC
S DIC="^AUPNPAT("
S DIC(0)="AEMQZ"
S DIC("S")="I '$G(^DPT(+Y,.35))"
S DIC("A")="Name, Chart No. or DOB: "
D ^DIC
K DIC
I Y<1 S BDMLLTQT="" Q
S ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,+Y)=""
Q
TEMPLATE ;SELECT SEARCH TEMPLATE
N DIC
S DIC="^DIBT("
S DIC(0)="AEMQZ"
S DIC("S")="I $O(^DIBT(+Y,1,0))"
D ^DIC
K DIC
Q:'+Y
M ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB)=^DIBT(+Y,1)
S BDMLSTAT="Z"
Q
CPRINT ;EP;TO PRINT LETTERS FROM LIST OR TEMPLATE
S DFN=0
F S DFN=$O(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,DFN)) Q:'DFN!$D(BDMOUT) D
.K ^TMP("BDMTMP",$J,"FUL"),BDMOUT
.S BDMLET=2
.S BDMRPDA=$G(^ACM(41,"AC",DFN,BDMRDA))
.S BDMIANL=1 D EN^XBNEW("EPPRINT^BDMLET","BDMLET;BDMRPDA,BDMRDA,BDMIANL;BDMLDA;BDMREGNM;DFN;BDMLSTAT;BDMOUT")
K BDMIANL
Q
PAUSE ;EP
S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
REGISTER ;
K DIC,BDMLREG
S DIC(0)="AEMQ"
S (DIC,DIE)="^ACM(41.1,",DIC("A")="REGISTER: "
S BDMLZDIC="^ACM(41.1)",DIC("S")="I $D(@BDMLZDIC@(+Y,""AU"",""B"",DUZ))"
D ^DIC
I Y=-1 W !!,"No register selected." Q
S BDMLREG=+Y
;which status
S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BDMLSTAT=Y,BDM("STATUS")=Y
REG1 ;
;gather up patients from register in ^XTMP
K ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB) S BDMLCNT=0,X=0 F S X=$O(^ACM(41,"B",BDMLREG,X)) Q:X'=+X D
.I BDMLSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=BDMLSTAT S BDMLCNT=BDMLCNT+1,^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,$P(^ACM(41,X,0),U,2))="" Q
.I BDMLSTAT="" S BDMLCNT=BDMLCNT+1,^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,$P(^ACM(41,X,0),U,2))=""
I '$D(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB)) W !,"No patients with that status in that register!" Q
W !!,"There are ",BDMLCNT," patients in the ",$P(^ACM(41.1,BDMLREG,0),U)," register with a status of ",BDMLSTAT,".",!!
D PAUSE
Q
BDMLLT ; IHS/CMI/LAB - VIEW PT RECORD LT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,10**;JUN 14, 2007;Build 12
+2 ;
EXIT ;
+1 DO EN^XBVK("BDML")
+2 KILL ^TMP($JOB,"BDMLLTVR")
+3 KILL ^XTMP("BDMLLT",BDMJOB,BDMBTH)
+4 KILL BDMJOB,BDMBTH
+5 QUIT
SELECT ;EP;TO SELECT BDMLLT LETTER
+1 KILL BDMLLTQT,BDMLLTOT
+2 DO LIST
S1 SET DIR(0)="NO^1:"_BDMLLTJ
+1 SET DIR("A")="Select LETTER NO."
+2 WRITE !
+3 DO DIR^BDMLLTD
+4 IF +Y<1!'$GET(BDMLLTTP(+Y))
SET BDMLLTQT=""
QUIT
+5 SET BDMLDA=+BDMLLTTP(+Y)
+6 QUIT
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT BDMLLT LETTER
+1 IF $GET(BDMLRTN)=""
SET (ZTRTN,BDMLRTN)="PRINT^BDMLLT"
+2 SET ZTDESC="PRINT BDMLLT PATIENT LETTER"
+3 SET ZTSAVE("ACM*")=""
+4 SET ZTSAVE("DFN")=""
+5 SET ZTSAVE("BDM")=""
+6 DO ^BDMLLTZ
+7 QUIT
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT BDMLLT LETTER
+1 QUIT
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
+1 NEW X
+2 KILL ^TMP($JOB,"BDMLLTVR"),BDMLLTJ
+3 SET VALMCNT=0
+4 KILL X
+5 SET $EXTRACT(X,5)="NO. LETTER"
+6 DO Z(X)
+7 KILL X
+8 SET $EXTRACT(X,5)="--- ------------------------------"
+9 DO Z(X)
+10 SET BDMLLTJ=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 BDMLLTJ=BDMLLTJ+1
+16 KILL X
+17 SET $EXTRACT(X,5)=BDMLLTJ
+18 SET $EXTRACT(X,10)=Y
+19 DO Z(X)
+20 SET BDMLLTTP(BDMLLTJ)=Z
End DoDot:2
End DoDot:1
+21 QUIT
LINE ;
+1 IF $LENGTH(Y)<81
Begin DoDot:1
+2 SET J=J+1
+3 SET BDMLLTTP(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 BDMLLTTP(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 BDMLLTTP(J,0)=Z
+12 QUIT
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
+1 DO SELECT
+2 IF '$GET(BDMLDA)
QUIT
+3 SET BDMLLTJB=$HOROLOG_$JOB
+4 DO ZIS
+5 QUIT
LIST ;LIST LETTERS
+1 KILL BDMLLTTP
+2 NEW BDML,BDMLLTX,BDMLLTY,BDMLLTZ
+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 BDMLLTJ=0
+12 SET BDML=""
+13 FOR
SET BDML=$ORDER(^BDMLET("B",BDML))
IF BDML=""
QUIT
Begin DoDot:1
+14 SET BDMLLTX=0
+15 FOR
SET BDMLLTX=$ORDER(^BDMLET("B",BDML,BDMLLTX))
IF 'BDMLLTX
QUIT
Begin DoDot:2
+16 SET BDMLLTY=$GET(^BDMLET(BDMLLTX,0))
+17 IF BDMLLTY=""
QUIT
+18 IF $GET(BDMLREG)
IF $PIECE(BDMLLTY,U,4)'=BDMLREG
QUIT
+19 SET BDMLLTJ=BDMLLTJ+1
+20 SET BDMLLTTP(BDMLLTJ)=BDMLLTX_U_BDML
+21 IF BDMLLTJ#3=1
WRITE !
+22 IF BDMLLTJ#3=2
WRITE ?27
+23 IF BDMLLTJ#3=0
WRITE ?53
+24 WRITE $JUSTIFY(BDMLLTJ,2)," "
+25 WRITE $EXTRACT(BDML,1,20)
End DoDot:2
End DoDot:1
+26 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP($JOB,"BDMLLTVR",VALMCNT,0)=X
+3 QUIT
DATE ;EP;TO PRINT LETTER DATE
+1 NEW Y
+2 SET Y=DT
+3 XECUTE ^DD("DD")
+4 SET Z=Y
+5 QUIT
COHORT ;EP;TO ESTABLISH COHORT OF PATIENTS TO PRINT
+1 SET BDMJOB=$JOB
SET BDMBTH=$HOROLOG
+2 DO SELECT
+3 IF '$GET(BDMLDA)
QUIT
+4 DO C1
+5 IF $DATA(BDMLLTQT)
QUIT
+6 SET BDMLBROW=""
+7 IF '$DATA(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB))
QUIT
+8 SET BDMLRTN="CPRINT^BDMLLT"
+9 DO ZIS
+10 KILL BDMLBROW,BDMJOB,BDMBTH,BDMLLTJB
+11 QUIT
C1 KILL ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER")
+1 SET BDMLLTJB=$HOROLOG_$JOB
+2 NEW DIR
+3 SET DIR(0)="SO^1:Individual Patient(s);2:Search Template of Patients;3:Members of a Case Management Register"
+4 SET DIR("A")="Create list for letters by"
+5 DO ^DIR
+6 KILL DIR
+7 IF 'Y
SET BDMLLTQT=""
QUIT
+8 IF Y=1
DO PATIENT
+9 IF Y=2
DO TEMPLATE
+10 IF Y=3
DO REGISTER
KILL BDMLREG
+11 IF '$DATA(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER"))
WRITE !!,"No patients selected."
DO PAUSE
QUIT
+12 QUIT
PATIENT ;SELECT INDIVIDUAL PATIENTS TO PRINT LETTER
+1 KILL BDMLLTQT
+2 FOR
DO P1
IF $DATA(BDMLLTQT)
QUIT
+3 KILL BDMLLTQT
+4 SET BDMLSTAT="Z"
+5 QUIT
P1 ;
+1 NEW DIC
+2 SET DIC="^AUPNPAT("
+3 SET DIC(0)="AEMQZ"
+4 SET DIC("S")="I '$G(^DPT(+Y,.35))"
+5 SET DIC("A")="Name, Chart No. or DOB: "
+6 DO ^DIC
+7 KILL DIC
+8 IF Y<1
SET BDMLLTQT=""
QUIT
+9 SET ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,+Y)=""
+10 QUIT
TEMPLATE ;SELECT SEARCH TEMPLATE
+1 NEW DIC
+2 SET DIC="^DIBT("
+3 SET DIC(0)="AEMQZ"
+4 SET DIC("S")="I $O(^DIBT(+Y,1,0))"
+5 DO ^DIC
+6 KILL DIC
+7 IF '+Y
QUIT
+8 MERGE ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB)=^DIBT(+Y,1)
+9 SET BDMLSTAT="Z"
+10 QUIT
CPRINT ;EP;TO PRINT LETTERS FROM LIST OR TEMPLATE
+1 SET DFN=0
+2 FOR
SET DFN=$ORDER(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,DFN))
IF 'DFN!$DATA(BDMOUT)
QUIT
Begin DoDot:1
+3 KILL ^TMP("BDMTMP",$JOB,"FUL"),BDMOUT
+4 SET BDMLET=2
+5 SET BDMRPDA=$GET(^ACM(41,"AC",DFN,BDMRDA))
+6 SET BDMIANL=1
DO EN^XBNEW("EPPRINT^BDMLET","BDMLET;BDMRPDA,BDMRDA,BDMIANL;BDMLDA;BDMREGNM;DFN;BDMLSTAT;BDMOUT")
End DoDot:1
+7 KILL BDMIANL
+8 QUIT
PAUSE ;EP
+1 SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 QUIT
REGISTER ;
+1 KILL DIC,BDMLREG
+2 SET DIC(0)="AEMQ"
+3 SET (DIC,DIE)="^ACM(41.1,"
SET DIC("A")="REGISTER: "
+4 SET BDMLZDIC="^ACM(41.1)"
SET DIC("S")="I $D(@BDMLZDIC@(+Y,""AU"",""B"",DUZ))"
+5 DO ^DIC
+6 IF Y=-1
WRITE !!,"No register selected."
QUIT
+7 SET BDMLREG=+Y
+8 ;which status
+9 SET DIR(0)="9002241,1"
SET DIR("A")="Which status"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)
QUIT
+11 SET BDMLSTAT=Y
SET BDM("STATUS")=Y
REG1 ;
+1 ;gather up patients from register in ^XTMP
+2 KILL ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB)
SET BDMLCNT=0
SET X=0
FOR
SET X=$ORDER(^ACM(41,"B",BDMLREG,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF BDMLSTAT]""
IF $PIECE($GET(^ACM(41,X,"DT")),U,1)=BDMLSTAT
SET BDMLCNT=BDMLCNT+1
SET ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,$PIECE(^ACM(41,X,0),U,2))=""
QUIT
+4 IF BDMLSTAT=""
SET BDMLCNT=BDMLCNT+1
SET ^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB,$PIECE(^ACM(41,X,0),U,2))=""
End DoDot:1
+5 IF '$DATA(^XTMP("BDMLLT",BDMJOB,BDMBTH,"BDMLLT CUSTOM LETTER",BDMLLTJB))
WRITE !,"No patients with that status in that register!"
QUIT
+6 WRITE !!,"There are ",BDMLCNT," patients in the ",$PIECE(^ACM(41.1,BDMLREG,0),U)," register with a status of ",BDMLSTAT,".",!!
+7 DO PAUSE
+8 QUIT
