Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLLT

APCLLT.m

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