- 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