APCLLT ; IHS/CMI/LAB - VIEW PT RECORD LT ;
;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
;
EN ;
D EN^XBVK("APCL")
S APCLLTVM="APCLLT LETTER"
D VALM(APCLLTVM)
Q
NOREG ;EP;CREATE LETTER WITHOUT REGISTER
N APCLLT
S APCLLT("NOREG")=""
S APCLLTVM="APCLLT LETTER"
D VALM(APCLLTVM)
Q
VALM(APCLLTVM) ;EP; -- main entry point for list templates
;D:'$D(APCLLT("NOREG")) REG
Q:$D(APCLLTQT)
K APCLREG
S VALMCC=1 ;1=screen mode, 0=scrolling mode
D TERM^VALM0
D CLEAR^VALM1
D EN^VALM(APCLLTVM)
D CLEAR^VALM1
D EXIT
Q
;
HDR ;EP
K VALMHDR
S VALMHDR(1)="Enter/Edit Letters"
Q
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXPND ; -- expand code
Q
EXIT ;
K APCLLTQT,APCLLTOT,APCLLTLD
;D EN^XBVK("APCL")
K ^TMP($J,"APCLLTVR")
Q
ADD ;EP;TO ADD APCLLT LETTERS
D EXIT
D A1
D E11:$G(APCLLTLD)
Q
A1 D CLEAR^VALM1
K APCLLTLD
S:$G(DIC(0))="" DIC(0)="AELMQZ"
S DIC="^APCLLET("
S DIC("A")="NAME OF LETTER: "
S:DIC(0)["L" DIC("DR")=".02////"_DUZ_";.03////"_DT,DLAYGO=9001004.6
W !?16,"------------------------------"
D DIC^APCLLTD
S:+Y>0 APCLLTLD=+Y
I Y=-1 G BACK
;tie to register??
D FULL^VALM1
W !!,"You can associate this letter with a Case Management System letter if you wish."
W !,"If you tie it to a CMS Register you will be able to pull items such"
W !,"as Where Followed and Case Manager from the register to insert in your"
W !,"letter."
W !
S APCLREG=""
S DIR(0)="Y",DIR("A")="Would you like to tie this letter to a CMS Register",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G BACK
I 'Y G BACK
D ^XBFMK
S DIC(0)="AEMQ"
S (DIC,DIE)="^ACM(41.1,",DIC("A")="REGISTER: "
S APCLZDIC="^ACM(41.1)",DIC("S")="I $D(@APCLZDIC@(+Y,""AU"",""B"",DUZ))"
D ^DIC
I Y=-1 W !!,"No register selected." G BACK
S APCLREG=+Y
D EN^XBVK("ACM")
D ^XBFMK
S DIE="^APCLLET(",DA=APCLLTLD,DR=".04///`"_APCLREG D ^DIE,^XBFMK
BACK S VALMBCK="R"
Q
WHICH ;EP;TO IDENTIFY WHICH LETTER TO USE
S DIC(0)="AEMQZ"
D A1
Q
SELECT ;EP;TO SELECT APCLLT LETTER
K APCLLTQT,APCLLTOT
D LIST
S1 S DIR(0)="NO^1:"_APCLLTJ
S DIR("A")="Select LETTER NO."
W !
D DIR^APCLLTD
I +Y<1!'$G(APCLLTTP(+Y)) S APCLLTQT="" Q
S APCLLTLD=+APCLLTTP(+Y)
Q
EDIT ;EP;TO EDIT APCLLT LETTER
D EXIT
D S1
I $D(APCLLTQT) K APCLLTQT D BACK Q
E11 D CLEAR^VALM1
S DA=APCLLTLD
S DIE="^APCLLET("
S DR=1
D DIE^APCLLTD
D PARSE
D BACK
Q
PRINT ;EP;TO PRINT APCLLT LETTER
Q:'$G(APCLLTLD)!'$G(DFN)
D CLEAR^VALM1:IO=IO(0)&(IOST["C-")
I APCLXCNT'=1 W @IOF
N A,B,C,D,X,Y,Z
S X=0
F S X=$O(^APCLLET(APCLLTLD,1,X)) Q:'X D
.S Y=$G(^APCLLET(APCLLTLD,1,X,0))
.I Y["|" D INTP
.W !,Y
Q
INTP ;INTERPRET VARIABLES
N ZZ,APCLZZZ,X,K
S X=Y
X ^%ZOSF("UPPERCASE")
S ZZ=Y
S APCLZZZ=$P(Y,"|")
F I=2:2 S J=$P(Y,"|",I) Q:J="" D
.S K=$P(J," ")
.I $T(@K)="" S ZZ="" Q
.D @K
.S ZZ=$P(ZZ,("|"_J_"|"))_Z_$P(ZZ,("|"_J_"|"),2)
S Y=ZZ
Q
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT APCLLT LETTER
S:$G(APCLRTN)="" (ZTRTN,APCLRTN)="PRINT^APCLLT"
S ZTDESC="PRINT APCLLT PATIENT LETTER"
S ZTSAVE("ACM*")=""
S ZTSAVE("DFN")=""
D ^APCLLTZ
Q
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT APCLLT LETTER
Q
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
N X
K ^TMP($J,"APCLLTVR"),APCLLTJ
S VALMCNT=0
K X
S $E(X,5)="NO. LETTER"
D Z(X)
K X
S $E(X,5)="--- ------------------------------"
D Z(X)
S APCLLTJ=0
S Y=""
F S Y=$O(^APCLLET("B",Y)) Q:Y="" D
.S Z=0
.F S Z=$O(^APCLLET("B",Y,Z)) Q:'Z D
..S APCLLTJ=APCLLTJ+1
..K X
..S $E(X,5)=APCLLTJ
..S $E(X,10)=Y
..D Z(X)
..S APCLLTTP(APCLLTJ)=Z
Q
ITEXT ;;
I1 ;;FIRST NAME;;2
I2 ;;LAST NAME;;2
I3 ;;CHART
I4 ;;ADDRESS;;2
I5 ;;DATE
I6 ;;PRIMARY PROVIDER NAME;;16
I7 ;;PHN;;16
I8 ;;CASE MANAGER NAME;;16
;;
INSERT ;EP;TO LIST INSERT ITEMS
S APCLLTVM="APCLLT LETTER ITEMS"
D VALM(APCLLTVM)
D BACK
Q
ILIST ;LIST ITEM TEXT
K ^TMP($J,"APCLLTVR")
N J,X,Y,Z,ZZ
S ZZ="ZL APCLLT S A=""I""_J,A=$T(@A)"
S VALMCNT=0
K X
S $E(X,5)="NO. INSERT"
D Z(X)
K X
S $E(X,5)="--- --------------------"
D Z(X)
;F J=3:1:7 D
F J=1:1:7 D
.X ZZ
.Q:A=""
.S A=$P(A,";;",2)
.K X
.S $E(X,5)=J
.S $E(X,10)=A
.D Z(X)
S X=""
D Z(X)
S X="You can include any of the INSERTS listed above by entering the NO. surrounded"
D Z(X)
S X="by the '|' character. For example, to include the patient's name and address"
D Z(X)
S X="you can add 2 lines to your letter such as:"
D Z(X)
S X=""
D Z(X)
S X="|1| |2| (or you can use |FIRST NAME| |LAST NAME|)"
D Z(X)
S X="|4| (or you can use |ADDRESS|)"
D Z(X)
S X=""
D Z(X)
S X="This will add 1 line for the name and multiple lines for street, city, etc."
D Z(X)
S X=""
D Z(X)
S X="Please note that you can only use inserts from the list above."
D Z(X)
Q
PARSE ;DIVIDE UP THE LETTER CONTENT
N I,J,K,X,Y,Z,ZZ,APCLLTTP
S (Z,ZZ)=""
S (J,X)=0
F S X=$O(^APCLLET(APCLLTLD,1,X)) Q:'X D
.S Y=$G(^APCLLET(APCLLTLD,1,X,0))
.Q:Y=""
.I Y["|" D VARS
.D LINE
Q:'$D(APCLLTTP)
S %X="APCLLTTP("
S %Y="^APCLLET("_APCLLTLD_",1,"
D %XY^%RCR
Q
VARS ;CONVERT VARIABLES
N I,J,K,X,Z
S ZZ="ZL APCLLT S X=""I""_J,X=$T(@X)"
F I=2:2 S J=$P(Y,"|",I) Q:J="" D:J
.X ZZ
.S Z=$P(X,";;",3)
.S X=$P(X,";;",2)
.S Y=$P(Y,("|"_J_"|"))_"|"_X_"|"_$P(Y,("|"_J_"|"),2)
Q
LINE ;
I $L(Y)<81 D Q
.S J=J+1
.S APCLLTTP(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 APCLLTTP(J,0)=Z
..S Z=""
.I Z="" S Z=K
.E S Z=Z_" "_K
I $L(Z) S J=J+1,APCLLTTP(J,0)=Z
Q
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
D SELECT
Q:'$G(APCLLTLD)
S APCLLTJB=$H_$J
D ZIS
Q
LIST ;LIST LETTERS
K APCLLTTP
N APCL,APCLLTX,APCLLTY,APCLLTZ
W @IOF
W !!?5,"APCLLT letters currently on file:"
W !!,"NO. LETTER"
W ?27,"NO. LETTER"
W ?54,"NO. LETTER"
W !,"--- --------------------"
W ?27,"--- --------------------"
W ?54,"--- --------------------"
S APCLLTJ=0
S APCL=""
F S APCL=$O(^APCLLET("B",APCL)) Q:APCL="" D
.S APCLLTX=0
.F S APCLLTX=$O(^APCLLET("B",APCL,APCLLTX)) Q:'APCLLTX D
..S APCLLTY=$G(^APCLLET(APCLLTX,0))
..Q:APCLLTY=""
..I $G(APCLREG),$P(APCLLTY,U,4)'=APCLREG Q
..S APCLLTJ=APCLLTJ+1
..S APCLLTTP(APCLLTJ)=APCLLTX_U_APCL
..W:APCLLTJ#3=1 !
..W:APCLLTJ#3=2 ?27
..W:APCLLTJ#3=0 ?53
..W $J(APCLLTJ,2)," "
..W $E(APCL,1,20)
Q
FIRST ;EP;TO PRINT PATIENT NAME IN A LETTER
S Z=$P($G(^DPT(DFN,0)),U)
S Z=$P($P(Z,",",2)," ")
Q
LAST ;EP;TO PRINT PATIENT NAME IN A LETTER
S Z=$P($G(^DPT(DFN,0)),U)
S Z=$P(Z,",")
Q
CHART ;EP;TO PRINT PATIENT CHART NUMBER
S Z="CHART NO.: "_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
Q
ADDRESS ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
S Z=$G(^DPT(DFN,.11))
W !
W:$G(APCLZZZ)]"" ?$L(APCLZZZ)
W $P(Z,U)
I $P(Z,U,2) D
.W !
.W:$G(APCLZZZ)]"" ?$L(APCLZZZ)
.W $P(Z,U,2)
I $P(Z,U,3) D
.W !
.W:$G(APCLZZZ)]"" ?$L(APCLZZZ)
.W $P(Z,U,3)
W !
W:$G(APCLZZZ)]"" ?$L(APCLZZZ)
W $P(Z,U,4),", ",$P($G(^DIC(5,+$P(Z,U,5),0)),U,2)," ",$P(Z,U,6)
S (Z,ZZ)=""
Q
FOLLOW ;EP;TO PRINT FOLLOW-UP MESSAGE
S APCLLT("STATUS")=$E($G(APCLLT("STATUS")))
Q
PRIMARY ;EP;TO PRINT PROVIDER NAME IN A LETTER
S Z=+$P($G(^AUPNPAT(DFN,0)),U,14)
S Z=$P($G(^VA(200,Z,0)),U)
S Z=$P($P(Z,",",2)," ")_" "_$P(Z,",")
Q
CASE ;EP;TO PRINT PROVIDER NAME IN A LETTER
Q:'$G(APCLREG)
S Z=+$P($G(^ACM(41,APCLREG,"DT")),U,6)
S Z=$P($G(^VA(200,Z,0)),U)
S Z=$P($P(Z,",",2)," ")_" "_$P(Z,",")
Q
PHN ;EP;TO PRINT PHN NAME IN A LETTER
Q:'$G(APCLREG)
S Z=+$P($G(^ACM(41,APCLREG,"DT")),U,7)
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(APCLLTQT) K APCLLTQT D BACK Q
S DA=APCLLTLD
S DIK="^APCLLET("
D ^DIK
D BACK
Q
Z(X) ;SET TMP NODE
S VALMCNT=VALMCNT+1
S ^TMP($J,"APCLLTVR",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
D SELECT
Q:'$G(APCLLTLD)
D C1
Q:$D(APCLLTQT)
S APCLBROW=""
Q:'$D(^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB))
S APCLRTN="CPRINT^APCLLT"
D ZIS
Q
C1 K ^TMP($J,"APCLLT CUSTOM LETTER")
S APCLLTJB=$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 APCLLTQT="" Q
I Y=1 D PATIENT
I Y=2 D TEMPLATE
I Y=3 D REGISTER K APCLREG
I '$D(^TMP($J,"APCLLT CUSTOM LETTER")) W !!,"No patients selected." D PAUSE Q
Q
PATIENT ;SELECT INDIVIDUAL PATIENTS TO PRINT LETTER
K APCLLTQT
F D P1 Q:$D(APCLLTQT)
K APCLLTQT
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 APCLLTQT="" Q
S ^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB,+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 ^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB)=^DIBT(+Y,1)
Q
CPRINT ;EP;TO PRINT LETTERS FROM LIST OR TEMPLATE
S DFN=0,APCLXCNT=0
F S DFN=$O(^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB,DFN)) Q:'DFN S APCLXCNT=APCLXCNT+1 D PRINT
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,APCLREG
S DIC(0)="AEMQ"
S (DIC,DIE)="^ACM(41.1,",DIC("A")="REGISTER: "
S APCLZDIC="^ACM(41.1)",DIC("S")="I $D(@APCLZDIC@(+Y,""AU"",""B"",DUZ))"
D ^DIC
I Y=-1 W !!,"No register selected." Q
S APCLREG=+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 APCLSTAT=Y
REG1 ;
;gather up patients from register in ^XTMP
K ^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB) S APCLCNT=0,X=0 F S X=$O(^ACM(41,"B",APCLREG,X)) Q:X'=+X D
.I APCLSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=APCLSTAT S APCLCNT=APCLCNT+1,^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB,$P(^ACM(41,X,0),U,2))="" Q
.I APCLSTAT="" S APCLCNT=APCLCNT+1,^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB,$P(^ACM(41,X,0),U,2))=""
I '$D(^TMP($J,"APCLLT CUSTOM LETTER",APCLLTJB)) W !,"No patients with that status in that register!" Q
W !!,"There are ",APCLCNT," patients in the ",$P(^ACM(41.1,APCLREG,0),U)," register with a status of ",APCLSTAT,".",!!
D PAUSE
Q
APCLLT ; IHS/CMI/LAB - VIEW PT RECORD LT ;
+1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
+2 ;
EN ;
+1 DO EN^XBVK("APCL")
+2 SET APCLLTVM="APCLLT LETTER"
+3 DO VALM(APCLLTVM)
+4 QUIT
NOREG ;EP;CREATE LETTER WITHOUT REGISTER
+1 NEW APCLLT
+2 SET APCLLT("NOREG")=""
+3 SET APCLLTVM="APCLLT LETTER"
+4 DO VALM(APCLLTVM)
+5 QUIT
VALM(APCLLTVM) ;EP; -- main entry point for list templates
+1 ;D:'$D(APCLLT("NOREG")) REG
+2 IF $DATA(APCLLTQT)
QUIT
+3 KILL APCLREG
+4 ;1=screen mode, 0=scrolling mode
SET VALMCC=1
+5 DO TERM^VALM0
+6 DO CLEAR^VALM1
+7 DO EN^VALM(APCLLTVM)
+8 DO CLEAR^VALM1
+9 DO EXIT
+10 QUIT
+11 ;
HDR ;EP
+1 KILL VALMHDR
+2 SET VALMHDR(1)="Enter/Edit Letters"
+3 QUIT
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
EXIT ;
+1 KILL APCLLTQT,APCLLTOT,APCLLTLD
+2 ;D EN^XBVK("APCL")
+3 KILL ^TMP($JOB,"APCLLTVR")
+4 QUIT
ADD ;EP;TO ADD APCLLT LETTERS
+1 DO EXIT
+2 DO A1
+3 IF $GET(APCLLTLD)
DO E11
+4 QUIT
A1 DO CLEAR^VALM1
+1 KILL APCLLTLD
+2 IF $GET(DIC(0))=""
SET DIC(0)="AELMQZ"
+3 SET DIC="^APCLLET("
+4 SET DIC("A")="NAME OF LETTER: "
+5 IF DIC(0)["L"
SET DIC("DR")=".02////"_DUZ_";.03////"_DT
SET DLAYGO=9001004.6
+6 WRITE !?16,"------------------------------"
+7 DO DIC^APCLLTD
+8 IF +Y>0
SET APCLLTLD=+Y
+9 IF Y=-1
GOTO BACK
+10 ;tie to register??
+11 DO FULL^VALM1
+12 WRITE !!,"You can associate this letter with a Case Management System letter if you wish."
+13 WRITE !,"If you tie it to a CMS Register you will be able to pull items such"
+14 WRITE !,"as Where Followed and Case Manager from the register to insert in your"
+15 WRITE !,"letter."
+16 WRITE !
+17 SET APCLREG=""
+18 SET DIR(0)="Y"
SET DIR("A")="Would you like to tie this letter to a CMS Register"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+19 IF $DATA(DIRUT)
GOTO BACK
+20 IF 'Y
GOTO BACK
+21 DO ^XBFMK
+22 SET DIC(0)="AEMQ"
+23 SET (DIC,DIE)="^ACM(41.1,"
SET DIC("A")="REGISTER: "
+24 SET APCLZDIC="^ACM(41.1)"
SET DIC("S")="I $D(@APCLZDIC@(+Y,""AU"",""B"",DUZ))"
+25 DO ^DIC
+26 IF Y=-1
WRITE !!,"No register selected."
GOTO BACK
+27 SET APCLREG=+Y
+28 DO EN^XBVK("ACM")
+29 DO ^XBFMK
+30 SET DIE="^APCLLET("
SET DA=APCLLTLD
SET DR=".04///`"_APCLREG
DO ^DIE
DO ^XBFMK
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 APCLLT LETTER
+1 KILL APCLLTQT,APCLLTOT
+2 DO LIST
S1 SET DIR(0)="NO^1:"_APCLLTJ
+1 SET DIR("A")="Select LETTER NO."
+2 WRITE !
+3 DO DIR^APCLLTD
+4 IF +Y<1!'$GET(APCLLTTP(+Y))
SET APCLLTQT=""
QUIT
+5 SET APCLLTLD=+APCLLTTP(+Y)
+6 QUIT
EDIT ;EP;TO EDIT APCLLT LETTER
+1 DO EXIT
+2 DO S1
+3 IF $DATA(APCLLTQT)
KILL APCLLTQT
DO BACK
QUIT
E11 DO CLEAR^VALM1
+1 SET DA=APCLLTLD
+2 SET DIE="^APCLLET("
+3 SET DR=1
+4 DO DIE^APCLLTD
+5 DO PARSE
+6 DO BACK
+7 QUIT
PRINT ;EP;TO PRINT APCLLT LETTER
+1 IF '$GET(APCLLTLD)!'$GET(DFN)
QUIT
+2 IF IO=IO(0)&(IOST["C-")
DO CLEAR^VALM1
+3 IF APCLXCNT'=1
WRITE @IOF
+4 NEW A,B,C,D,X,Y,Z
+5 SET X=0
+6 FOR
SET X=$ORDER(^APCLLET(APCLLTLD,1,X))
IF 'X
QUIT
Begin DoDot:1
+7 SET Y=$GET(^APCLLET(APCLLTLD,1,X,0))
+8 IF Y["|"
DO INTP
+9 WRITE !,Y
End DoDot:1
+10 QUIT
INTP ;INTERPRET VARIABLES
+1 NEW ZZ,APCLZZZ,X,K
+2 SET X=Y
+3 XECUTE ^%ZOSF("UPPERCASE")
+4 SET ZZ=Y
+5 SET APCLZZZ=$PIECE(Y,"|")
+6 FOR I=2:2
SET J=$PIECE(Y,"|",I)
IF J=""
QUIT
Begin DoDot:1
+7 SET K=$PIECE(J," ")
+8 IF $TEXT(@K)=""
SET ZZ=""
QUIT
+9 DO @K
+10 SET ZZ=$PIECE(ZZ,("|"_J_"|"))_Z_$PIECE(ZZ,("|"_J_"|"),2)
End DoDot:1
+11 SET Y=ZZ
+12 QUIT
ZIS ;EP;TO SELECT DEVICE ON WHICH TO PRINT APCLLT LETTER
+1 IF $GET(APCLRTN)=""
SET (ZTRTN,APCLRTN)="PRINT^APCLLT"
+2 SET ZTDESC="PRINT APCLLT PATIENT LETTER"
+3 SET ZTSAVE("ACM*")=""
+4 SET ZTSAVE("DFN")=""
+5 DO ^APCLLTZ
+6 QUIT
MULTIPLE ;EP;UTILTIY TO SELECT MULTIPLE PATIENTS FOR WHICH TO PRINT APCLLT LETTER
+1 QUIT
LINIT ;EP;TO CREATE ARRAY OF NAMES OF EXISTING LETTERS
+1 NEW X
+2 KILL ^TMP($JOB,"APCLLTVR"),APCLLTJ
+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 APCLLTJ=0
+11 SET Y=""
+12 FOR
SET Y=$ORDER(^APCLLET("B",Y))
IF Y=""
QUIT
Begin DoDot:1
+13 SET Z=0
+14 FOR
SET Z=$ORDER(^APCLLET("B",Y,Z))
IF 'Z
QUIT
Begin DoDot:2
+15 SET APCLLTJ=APCLLTJ+1
+16 KILL X
+17 SET $EXTRACT(X,5)=APCLLTJ
+18 SET $EXTRACT(X,10)=Y
+19 DO Z(X)
+20 SET APCLLTTP(APCLLTJ)=Z
End DoDot:2
End DoDot:1
+21 QUIT
ITEXT ;;
I1 ;;FIRST NAME;;2
I2 ;;LAST NAME;;2
I3 ;;CHART
I4 ;;ADDRESS;;2
I5 ;;DATE
I6 ;;PRIMARY PROVIDER NAME;;16
I7 ;;PHN;;16
I8 ;;CASE MANAGER NAME;;16
+1 ;;
INSERT ;EP;TO LIST INSERT ITEMS
+1 SET APCLLTVM="APCLLT LETTER ITEMS"
+2 DO VALM(APCLLTVM)
+3 DO BACK
+4 QUIT
ILIST ;LIST ITEM TEXT
+1 KILL ^TMP($JOB,"APCLLTVR")
+2 NEW J,X,Y,Z,ZZ
+3 SET ZZ="ZL APCLLT S A=""I""_J,A=$T(@A)"
+4 SET VALMCNT=0
+5 KILL X
+6 SET $EXTRACT(X,5)="NO. INSERT"
+7 DO Z(X)
+8 KILL X
+9 SET $EXTRACT(X,5)="--- --------------------"
+10 DO Z(X)
+11 ;F J=3:1:7 D
+12 FOR J=1:1:7
Begin DoDot:1
+13 XECUTE ZZ
+14 IF A=""
QUIT
+15 SET A=$PIECE(A,";;",2)
+16 KILL X
+17 SET $EXTRACT(X,5)=J
+18 SET $EXTRACT(X,10)=A
+19 DO Z(X)
End DoDot:1
+20 SET X=""
+21 DO Z(X)
+22 SET X="You can include any of the INSERTS listed above by entering the NO. surrounded"
+23 DO Z(X)
+24 SET X="by the '|' character. For example, to include the patient's name and address"
+25 DO Z(X)
+26 SET X="you can add 2 lines to your letter such as:"
+27 DO Z(X)
+28 SET X=""
+29 DO Z(X)
+30 SET X="|1| |2| (or you can use |FIRST NAME| |LAST NAME|)"
+31 DO Z(X)
+32 SET X="|4| (or you can use |ADDRESS|)"
+33 DO Z(X)
+34 SET X=""
+35 DO Z(X)
+36 SET X="This will add 1 line for the name and multiple lines for street, city, etc."
+37 DO Z(X)
+38 SET X=""
+39 DO Z(X)
+40 SET X="Please note that you can only use inserts from the list above."
+41 DO Z(X)
+42 QUIT
PARSE ;DIVIDE UP THE LETTER CONTENT
+1 NEW I,J,K,X,Y,Z,ZZ,APCLLTTP
+2 SET (Z,ZZ)=""
+3 SET (J,X)=0
+4 FOR
SET X=$ORDER(^APCLLET(APCLLTLD,1,X))
IF 'X
QUIT
Begin DoDot:1
+5 SET Y=$GET(^APCLLET(APCLLTLD,1,X,0))
+6 IF Y=""
QUIT
+7 IF Y["|"
DO VARS
+8 DO LINE
End DoDot:1
+9 IF '$DATA(APCLLTTP)
QUIT
+10 SET %X="APCLLTTP("
+11 SET %Y="^APCLLET("_APCLLTLD_",1,"
+12 DO %XY^%RCR
+13 QUIT
VARS ;CONVERT VARIABLES
+1 NEW I,J,K,X,Z
+2 SET ZZ="ZL APCLLT 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 XECUTE ZZ
+5 SET Z=$PIECE(X,";;",3)
+6 SET X=$PIECE(X,";;",2)
+7 SET Y=$PIECE(Y,("|"_J_"|"))_"|"_X_"|"_$PIECE(Y,("|"_J_"|"),2)
End DoDot:1
+8 QUIT
LINE ;
+1 IF $LENGTH(Y)<81
Begin DoDot:1
+2 SET J=J+1
+3 SET APCLLTTP(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 APCLLTTP(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 APCLLTTP(J,0)=Z
+12 QUIT
PATLET ;EP;TO SELECT AND PROCESS PATIENT LETTER
+1 DO SELECT
+2 IF '$GET(APCLLTLD)
QUIT
+3 SET APCLLTJB=$HOROLOG_$JOB
+4 DO ZIS
+5 QUIT
LIST ;LIST LETTERS
+1 KILL APCLLTTP
+2 NEW APCL,APCLLTX,APCLLTY,APCLLTZ
+3 WRITE @IOF
+4 WRITE !!?5,"APCLLT 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 APCLLTJ=0
+12 SET APCL=""
+13 FOR
SET APCL=$ORDER(^APCLLET("B",APCL))
IF APCL=""
QUIT
Begin DoDot:1
+14 SET APCLLTX=0
+15 FOR
SET APCLLTX=$ORDER(^APCLLET("B",APCL,APCLLTX))
IF 'APCLLTX
QUIT
Begin DoDot:2
+16 SET APCLLTY=$GET(^APCLLET(APCLLTX,0))
+17 IF APCLLTY=""
QUIT
+18 IF $GET(APCLREG)
IF $PIECE(APCLLTY,U,4)'=APCLREG
QUIT
+19 SET APCLLTJ=APCLLTJ+1
+20 SET APCLLTTP(APCLLTJ)=APCLLTX_U_APCL
+21 IF APCLLTJ#3=1
WRITE !
+22 IF APCLLTJ#3=2
WRITE ?27
+23 IF APCLLTJ#3=0
WRITE ?53
+24 WRITE $JUSTIFY(APCLLTJ,2)," "
+25 WRITE $EXTRACT(APCL,1,20)
End DoDot:2
End DoDot:1
+26 QUIT
FIRST ;EP;TO PRINT PATIENT NAME IN A LETTER
+1 SET Z=$PIECE($GET(^DPT(DFN,0)),U)
+2 SET Z=$PIECE($PIECE(Z,",",2)," ")
+3 QUIT
LAST ;EP;TO PRINT PATIENT NAME IN A LETTER
+1 SET Z=$PIECE($GET(^DPT(DFN,0)),U)
+2 SET Z=$PIECE(Z,",")
+3 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
ADDRESS ;EP;TO PRINT PATIENT'S ADDRESS IN A LETTER
+1 SET Z=$GET(^DPT(DFN,.11))
+2 WRITE !
+3 IF $GET(APCLZZZ)]""
WRITE ?$LENGTH(APCLZZZ)
+4 WRITE $PIECE(Z,U)
+5 IF $PIECE(Z,U,2)
Begin DoDot:1
+6 WRITE !
+7 IF $GET(APCLZZZ)]""
WRITE ?$LENGTH(APCLZZZ)
+8 WRITE $PIECE(Z,U,2)
End DoDot:1
+9 IF $PIECE(Z,U,3)
Begin DoDot:1
+10 WRITE !
+11 IF $GET(APCLZZZ)]""
WRITE ?$LENGTH(APCLZZZ)
+12 WRITE $PIECE(Z,U,3)
End DoDot:1
+13 WRITE !
+14 IF $GET(APCLZZZ)]""
WRITE ?$LENGTH(APCLZZZ)
+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
FOLLOW ;EP;TO PRINT FOLLOW-UP MESSAGE
+1 SET APCLLT("STATUS")=$EXTRACT($GET(APCLLT("STATUS")))
+2 QUIT
PRIMARY ;EP;TO PRINT PROVIDER NAME IN A LETTER
+1 SET Z=+$PIECE($GET(^AUPNPAT(DFN,0)),U,14)
+2 SET Z=$PIECE($GET(^VA(200,Z,0)),U)
+3 SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+4 QUIT
CASE ;EP;TO PRINT PROVIDER NAME IN A LETTER
+1 IF '$GET(APCLREG)
QUIT
+2 SET Z=+$PIECE($GET(^ACM(41,APCLREG,"DT")),U,6)
+3 SET Z=$PIECE($GET(^VA(200,Z,0)),U)
+4 SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+5 QUIT
PHN ;EP;TO PRINT PHN NAME IN A LETTER
+1 IF '$GET(APCLREG)
QUIT
+2 SET Z=+$PIECE($GET(^ACM(41,APCLREG,"DT")),U,7)
+3 SET Z=$PIECE($GET(^VA(200,Z,0)),U)
+4 SET Z=$PIECE($PIECE(Z,",",2)," ")_" "_$PIECE(Z,",")
+5 QUIT
DELETE ;DELETE LETTER
+1 DO S1
+2 IF $DATA(APCLLTQT)
KILL APCLLTQT
DO BACK
QUIT
+3 SET DA=APCLLTLD
+4 SET DIK="^APCLLET("
+5 DO ^DIK
+6 DO BACK
+7 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP($JOB,"APCLLTVR",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 DO SELECT
+2 IF '$GET(APCLLTLD)
QUIT
+3 DO C1
+4 IF $DATA(APCLLTQT)
QUIT
+5 SET APCLBROW=""
+6 IF '$DATA(^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB))
QUIT
+7 SET APCLRTN="CPRINT^APCLLT"
+8 DO ZIS
+9 QUIT
C1 KILL ^TMP($JOB,"APCLLT CUSTOM LETTER")
+1 SET APCLLTJB=$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 APCLLTQT=""
QUIT
+8 IF Y=1
DO PATIENT
+9 IF Y=2
DO TEMPLATE
+10 IF Y=3
DO REGISTER
KILL APCLREG
+11 IF '$DATA(^TMP($JOB,"APCLLT CUSTOM LETTER"))
WRITE !!,"No patients selected."
DO PAUSE
QUIT
+12 QUIT
PATIENT ;SELECT INDIVIDUAL PATIENTS TO PRINT LETTER
+1 KILL APCLLTQT
+2 FOR
DO P1
IF $DATA(APCLLTQT)
QUIT
+3 KILL APCLLTQT
+4 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 APCLLTQT=""
QUIT
+9 SET ^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB,+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 ^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB)=^DIBT(+Y,1)
+9 QUIT
CPRINT ;EP;TO PRINT LETTERS FROM LIST OR TEMPLATE
+1 SET DFN=0
SET APCLXCNT=0
+2 FOR
SET DFN=$ORDER(^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB,DFN))
IF 'DFN
QUIT
SET APCLXCNT=APCLXCNT+1
DO PRINT
+3 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,APCLREG
+2 SET DIC(0)="AEMQ"
+3 SET (DIC,DIE)="^ACM(41.1,"
SET DIC("A")="REGISTER: "
+4 SET APCLZDIC="^ACM(41.1)"
SET DIC("S")="I $D(@APCLZDIC@(+Y,""AU"",""B"",DUZ))"
+5 DO ^DIC
+6 IF Y=-1
WRITE !!,"No register selected."
QUIT
+7 SET APCLREG=+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 APCLSTAT=Y
REG1 ;
+1 ;gather up patients from register in ^XTMP
+2 KILL ^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB)
SET APCLCNT=0
SET X=0
FOR
SET X=$ORDER(^ACM(41,"B",APCLREG,X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF APCLSTAT]""
IF $PIECE($GET(^ACM(41,X,"DT")),U,1)=APCLSTAT
SET APCLCNT=APCLCNT+1
SET ^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB,$PIECE(^ACM(41,X,0),U,2))=""
QUIT
+4 IF APCLSTAT=""
SET APCLCNT=APCLCNT+1
SET ^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB,$PIECE(^ACM(41,X,0),U,2))=""
End DoDot:1
+5 IF '$DATA(^TMP($JOB,"APCLLT CUSTOM LETTER",APCLLTJB))
WRITE !,"No patients with that status in that register!"
QUIT
+6 WRITE !!,"There are ",APCLCNT," patients in the ",$PIECE(^ACM(41.1,APCLREG,0),U)," register with a status of ",APCLSTAT,".",!!
+7 DO PAUSE
+8 QUIT
