PSOTPCLP ;BIRM/PDW-PRINT PATIENT LETTERS ;AUG 5,2003
;;7.0;OUTPATIENT PHARMACY;**145,227,233**;DEC 1997;Build 8
Q
PRINT ; select options
Q ;placed out of order by patch PSO*7*227
K ^TMP($J,"TPBLET"),TMP($J,"TPCLW")
D EXIT ;INITIALIZE
;build INST to show incompleted Institutions
K INST S DIVDA=0 F S DIVDA=$O(^PS(52.92,DIVDA)) Q:DIVDA'>0 D
. S INST(DIVDA)=$$GET1^DIQ(52.92,DIVDA,.01)
S XX=$$INSTCHK^PSOTPCL I $G(PSOSTOP) Q
K INST S DIVDA=0 F S DIVDA=$O(^PS(52.92,DIVDA)) Q:DIVDA'>0 D
. Q:$$CHKINST^PSOTPCL(DIVDA)
. S INST(DIVDA)=$$GET1^DIQ(52.92,DIVDA,.01)
K PARAM,PATLST
K DIR S DIR(0)="SO^A:Print all letters that have not printed;P:Print letter by a patient or multiple patients;I:Print by institution (all, one, or a selection)" D ^DIR
I Y="A" S PARAM("SORT")="I",PATLST="",PARAM("LP")="N" G DEVICE
I Y="P" G PATIENT
I Y="I" G DIVISION
W !,"None Selected - Quitting",! H 3
G EXIT
PATIENT ; print by patients
S PARAM("SORT")="P",PARAM("LP")="B"
D PATSEL ; build PATLST("patient name")=DFN
G:($D(PATLST)<10) EXIT
G DEVICE
DIVISION ;print by division
K DIR S DIR(0)="SO^N:Letters NOT Printed;P:Letters Printed;B:Both"
D ^DIR Q:"NPB"'[Y
S PARAM("LP")=Y
S PARAM("SORT")="I"
K INST D SEL^PSOTPCL
I ($D(INST)<10) W !,"No Selection Made - Quitting",! H 3 G EXIT
G DEVICE
PATSEL ; Select one or more patients
K PATLST
S DIC="^PS(52.91,",DIC(0)="AEQM",DIC("W")="D DSPPAT^PSOTPCLP(+Y)"
F S DIC("W")="D DSPPAT^PSOTPCLP(+Y)" D ^DIC Q:Y'>0 S DFN=+Y,PTNM=$$GET1^DIQ(52.91,DFN,.01),PATLST(PTNM,DFN)="" D
. ;test death date
. S XX=$$GET1^DIQ(2,DFN,.351) I XX'="" D Q
.. W !!,"Sorry, ",PTNM," died ",XX,!
.. K PATLST(PTNM,DFN) H 3
. ;test expired date
. S EXPDTI=$$GET1^DIQ(52.91,DFN,2,"I")
. I EXPDTI,DT>EXPDTI D
.. S EXPDT=$$GET1^DIQ(52.91,+DFN,2)
.. W !,"Sorry, ",PTNM,"'s eligibility expired ",EXPDT,! K PATLST(PTNM,DFN)
. ;check divisions required data
. S DIVDA=$$GET1^DIQ(52.91,DFN,7,"I")
. S XX=$$CHKINST^PSOTPCL(DIVDA) I XX D
.. W !!,"Sorry, ",$$GET1^DIQ(52.91,DFN,7)," is missing required fields.",!!
.. K PATLST(PTNM,DFN)
;
LST I ($D(PATLST)<10) W !,"No Patients Selected - Quitting",! H 3 S PATLST="" Q
W !!,"You have selected:",!
S PATNM="" F I=1:1 S PATNM=$O(PATLST(PATNM)) Q:'$L(PATNM) S DFN=0 F S DFN=$O(PATLST(PATNM,DFN)) Q:DFN'>0 W !,PATNM D DSPPAT(DFN) I '(I#20) D D ^DIR I X["^" Q
.K DIR S DIR(0)="E",DIR("A")="<cr> - Continue ""^"" - Stop Display"
;
W ! K DIR S DIR(0)="Y",DIR("A")="Is the above correct ",DIR("B")="YES" D ^DIR
I 'Y G PATSEL
Q
DSPPAT(DFN) ; Display Division and expire date
N DIVNM,EXPDT,PRTDT
S DIVNM=$$GET1^DIQ(52.91,DFN,7) W ?32,$E(DIVNM,1,15)
S EXPDT=$$GET1^DIQ(52.91,DFN,2,"I")
I EXPDT S EXPDT=$$FMTE^XLFDT(EXPDT,"2D") W ?50,"Inact ",EXPDT
S PRTDT=$$GET1^DIQ(52.91,DFN,11,"I")
I PRTDT S PRTDT=$$FMTE^XLFDT(PRTDT,"2D") W ?66,"Prt ",PRTDT
Q
DEVICE ;
W !,"Queueing is recommended",!
S %ZIS="Q" D ^%ZIS
Q:POP
I $D(IO("Q")) D K ZTSK G EXIT
. S (PATLST,INST,PARAM)=""
. S ZTRTN="DEQUE^PSOTPCLP",ZTDESC="TPB PRINT PATIENT LETTERS"
. F XX="PATLST*","INST*","PARAM*" S ZTSAVE(XX)=""
. ;W ! ZW ZTRTN,ZTDESC,PATLST,INST,PARAM,ZTSAVE
. D ^%ZTLOAD
. I $G(ZTSK) W !!,"Tasked with "_ZTSK
; (code falls through if not queued)
DEQUE ; DEQUE/PRINT LETTERS
K ^TMP($J,"TPBLET")
I PARAM("SORT")="P" G SORTPAT
S DIVDA=0 F S DIVDA=$O(INST(DIVDA)) Q:DIVDA'>0 D
. S DFN=0 F S DFN=$O(^PS(52.91,"AC",DIVDA,DFN)) Q:DFN'>0 D
.. S PTNM=$$GET1^DIQ(52.91,DFN,.01)
.. S EXPDTI=$P(^PS(52.91,DFN,0),"^",3),LTPDTI=$P(^(0),"^",12)
.. Q:EXPDTI
.. Q:$L($$GET1^DIQ(2,DFN,.351))
.. I PARAM("LP")="N",LTPDTI Q
.. I PARAM("LP")="P",'LTPDTI Q
.. S ^TMP($J,"TPBLET",DIVDA,PTNM,DFN)=""
G PRTLET
SORTPAT ; sort by patient
K ^TMP($J,"TPBLET")
S PTNM="" F S PTNM=$O(PATLST(PTNM)) Q:PTNM="" D
. S DFN=0 F S DFN=$O(PATLST(PTNM,DFN)) Q:DFN'>0 D
.. S DA0=^PS(52.91,DFN,0),EXPDTI=$P(DA0,"^",3),LTPDTI=$P(DA0,"^",12),DIVDA=$P(DA0,"^",8)
.. Q:EXPDTI
.. I PARAM("LP")="N",LTPDTI Q
.. I PARAM("LP")="P",'LTPDTI Q
.. S ^TMP($J,"TPBLET",DIVDA,PTNM,DFN)=""
G PRTLET
Q
PRTLET ; pull DIVDAs and DFNs from ^TMP($J,"TPBLET",
D LOADTMP^PSOTPCLW ; load letter body into TMP
K DIVCNT
S DIVDA=0 F S DIVDA=$O(^TMP($J,"TPBLET",DIVDA)) Q:DIVDA'>0 D
. S XX=$$CHKINST^PSOTPCL(DIVDA) I XX S DIVCNT(DIVDA)=0 Q
. D DIV ;GETDIV(DIVDA) ;load institution/parent data for print
. S PTNM="" F S PTNM=$O(^TMP($J,"TPBLET",DIVDA,PTNM)) Q:PTNM="" D
.. S DFN=0
.. F S DFN=$O(^TMP($J,"TPBLET",DIVDA,PTNM,DFN)) Q:DFN'>0 D
... S DIVCNT(DIVDA)=$G(DIVCNT(DIVDA))+1
... D LETTER(DFN)
... S $P(^PS(52.91,DFN,0),U,12)=DT ;set print date
; summary of printing
S Y=DT D D^DIQ S SRDT=Y
W @IOF,!!,?10,"SUMMARY of TPB LETTER PRINTING ",SRDT
W !!
I '$D(DIVCNT) W !!,"NO DATA TO PRINT",!! G EXIT
S DIVDA=0 F S DIVDA=$O(DIVCNT(DIVDA)) Q:DIVDA'>0 D
. W !,?5,$$GET1^DIQ(52.92,DIVDA,.01),?40,DIVCNT(DIVDA)
W !
G EXIT
;
LETTER(DFN) ; print letter , division variables information must be present
U IO
D GETPAT(DFN)
I EXPDT,EXPDT'>DT Q ; patient inactive on printing date
D HEADER
F LN=1:1 Q:'$D(^TMP($J,"TPCLW","P1",LN)) W !,^(LN)
W ?30,"PHARMACY SERVICE",!,?30,DIVNM
I $L(MADD1) D I 1
. W !,?30,MADD1
. W:$L(MADD2) !,?30,MADD2
. W !,?30,MCITY,", ",MSTATE," ",MZIP
E W !,?30,ADD1 D
. W:$L(ADD2) !,?30,ADD2
. W !,?30,CITY,", ",STATE," ",ZIP
F LN=1:1 Q:'$D(^TMP($J,"TPCLW","P2",LN)) W !,^(LN)
W " ",PHN1 W:$L(PHN2) ", or ",PHN2 W ".",!
F LN=1:1 Q:'$D(^TMP($J,"TPCLW","P3",LN)) W:LN>1 ! W ^(LN)
W !!!!,?4,SIG1 W:$L(SIG2) !,?4,SIG2 W:$L(SIG3) !,?4,SIG3
W !
Q
GETPAT(DFN) ;GET PATIENT DATA
K PTNM,EXPDT,SRANAME,TITLE,SRNM,PTSTATE,VADM,VAPA
S PTNM=$$GET1^DIQ(52.91,DFN,.01),EXPDT=$$GET1^DIQ(52.91,DFN,2,"I")
;I EXPDT,DT'>EXPDT Q
D DEM^VADPT,ADD^VADPT
S PTLNM=$P(PTNM,","),PTXNM=$P(PTNM,",")
S SRANAME=$P(VADM(1),"^"),X=$P(SRANAME,","),Y=$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
S TITLE=$S($P(VADM(5),"^")="F":"Ms. ",1:"Mr. "),SRANAME=TITLE_Y
S Y=DT D D^DIQ S SRDT=Y
S SEX=$P(VADM(5),"^")
S SRNM=$P(VADM(1),",",2)_" "_$P(VADM(1),",")
S PADD1=$G(VAPA(1)),PADD2=$G(VAPA(2)),PADD3=$G(VAPA(3))
S PCITY=$G(VAPA(4)),PTSTATE=$P($G(VAPA(5)),U,2),PZIP=$G(VAPA(6))
N PSOBADR,PSOTEMP
S PSOBADR=$$BADADR^DGUTL3(DFN) I PSOBADR S PSOTEMP=$$CHKTEMP^PSOBAI(DFN) D
.I 'PSOTEMP S PADD1="** BAD ADDRESS INDICATED **",PADD2="",PADD3="",PCITY="",PSTATE="",PZIP=""
CCADD ; Get Confidential Correspondence Address if one is active
; and has the category "all other".
;
; See if CC address exists
I '$G(VAPA(12)) Q
; code to check the CC category in the variable array VAPA(22)
; check catagories
S XX=0 F CC=1,2,5 I $P($G(VAPA(22,CC)),U,3)="Y" S XX=1
Q:'XX
S SRCCADD=1
S:$G(VAPA(17)) PTSTATE=$P(^DIC(5,$P(VAPA(17),"^"),0),"^",2)
S PADD1=$G(VAPA(13)),PADD2=$G(VAPA(14)),PADD3=$G(VAPA(15))
S PCITY=$G(VAPA(16)),PTSTAT=$P(VAPA(17),U,2),PZIP=$P(VAPA(18),U,2)
Q
U IO
W @IOF
W !!,?(80-$L(DIVNM))\2,DIVNM
W !,?(80-$L(ADD1))\2,ADD1
W:$L(ADD2) !,?(80-$L(ADD2))\2,ADD2
S XX=CITY_", "_STATE_" "_ZIP
W !,?(80-$L(XX))\2,XX
F Y=$Y:1:10 W !
W !,?4,SRNM,?65,SRDT,!,?4,PADD1 I PADD2'="" W !,?4,PADD2 I PADD3'="" W !,?4,VAPA(3)
W:PCITY'="" !,?4,PCITY_", "_PTSTATE_" "_PZIP W !!!
Q
DIV D GETDIV(DIVDA)
I $L(PARDIV) S DIVDA2=$$GET1^DIQ(52.92,DIVDA,.02,"I") D GETDIV(DIVDA2)
Q
GETDIV(DIVDA) ; GET DIVISIONAL DATA
K DIVNM,PARDIV,PHN1,PHN2,ADD1,ADD2,CITY,ZIP,STATE,MADD1,MADD2,MCITY,MZIP,SIG1,SIG2,SIG3
;
F FLDX="DIVNM^.01","PARDIV^.02","PHN1^.03","PHN2^.04","ADD1^.05","ADD2^.06","CITY^.07","ZIP^.08","STATE^.09" D GET1(52.92,DIVDA,FLDX)
;
F FLDX="MADD1^1.01","MADD2^1.02","MCITY^1.03","MSTATE^1.04","MZIP^1.05","SIG1^2.01","SIG2^2.02","SIG3^2.03" D GET1(52.92,DIVDA,FLDX)
;
Q
GET1(FILE,FLIEN,FLDX) ; "Variable^FLD" load variable = FILE,FLD
N VAR S VAR=$P(FLDX,"^"),FLD=$P(FLDX,"^",2),@VAR=$$GET1^DIQ(FILE,FLIEN,FLD)
Q
EXIT ;
D ^%ZISC
I $G(ZTSK) D KILL^%ZTLOAD
K ADD1,ADD2,CHK,CITY,DIV,DIVCNT,DIVDA,DIVDA2,DIVNM,DIVX
K EXPDT,EXPDTI,FAC,FDA,FLD,FLDX,FILE,FLD,FLDX,FLIEN
K I,INST,LN,LOCDA,LTPDTI,MADD1,MADD2,MCITY,MZIP,PAR,PARAM
K PARDIV,PATLST,PATNM,PHN1,PHN2,POP,PRTDT,PSOSTOP,PTLNM,PTNM
K PTSTATE,PTXNM,SEX,SIG1,SIG2,SIG3,SRNAME,SRDT,STATE,TITLE
K VADM,VAPA,VAR,XFLD,XX,YFLD,YY,ZIP,ZTDESC
K ^TMP($J,"TPBLET"),^TMP($J,"TPCLW")
Q
LOAD K PATLST S DFN=0 F S DFN=$O(^PS(52.91,DFN)) Q:DFN'>0 S PATLST($$GET1^DIQ(52.91,DFN,.01))=DFN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOTPCLP 8624 printed Nov 22, 2024@17:45:45 Page 2
PSOTPCLP ;BIRM/PDW-PRINT PATIENT LETTERS ;AUG 5,2003
+1 ;;7.0;OUTPATIENT PHARMACY;**145,227,233**;DEC 1997;Build 8
+2 QUIT
PRINT ; select options
+1 ;placed out of order by patch PSO*7*227
QUIT
+2 KILL ^TMP($JOB,"TPBLET"),TMP($JOB,"TPCLW")
+3 ;INITIALIZE
DO EXIT
+4 ;build INST to show incompleted Institutions
+5 KILL INST
SET DIVDA=0
FOR
SET DIVDA=$ORDER(^PS(52.92,DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+6 SET INST(DIVDA)=$$GET1^DIQ(52.92,DIVDA,.01)
End DoDot:1
+7 SET XX=$$INSTCHK^PSOTPCL
IF $GET(PSOSTOP)
QUIT
+8 KILL INST
SET DIVDA=0
FOR
SET DIVDA=$ORDER(^PS(52.92,DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+9 if $$CHKINST^PSOTPCL(DIVDA)
QUIT
+10 SET INST(DIVDA)=$$GET1^DIQ(52.92,DIVDA,.01)
End DoDot:1
+11 KILL PARAM,PATLST
+12 KILL DIR
SET DIR(0)="SO^A:Print all letters that have not printed;P:Print letter by a patient or multiple patients;I:Print by institution (all, one, or a selection)"
DO ^DIR
+13 IF Y="A"
SET PARAM("SORT")="I"
SET PATLST=""
SET PARAM("LP")="N"
GOTO DEVICE
+14 IF Y="P"
GOTO PATIENT
+15 IF Y="I"
GOTO DIVISION
+16 WRITE !,"None Selected - Quitting",!
HANG 3
+17 GOTO EXIT
PATIENT ; print by patients
+1 SET PARAM("SORT")="P"
SET PARAM("LP")="B"
+2 ; build PATLST("patient name")=DFN
DO PATSEL
+3 if ($DATA(PATLST)<10)
GOTO EXIT
+4 GOTO DEVICE
DIVISION ;print by division
+1 KILL DIR
SET DIR(0)="SO^N:Letters NOT Printed;P:Letters Printed;B:Both"
+2 DO ^DIR
if "NPB"'[Y
QUIT
+3 SET PARAM("LP")=Y
+4 SET PARAM("SORT")="I"
+5 KILL INST
DO SEL^PSOTPCL
+6 IF ($DATA(INST)<10)
WRITE !,"No Selection Made - Quitting",!
HANG 3
GOTO EXIT
+7 GOTO DEVICE
PATSEL ; Select one or more patients
+1 KILL PATLST
+2 SET DIC="^PS(52.91,"
SET DIC(0)="AEQM"
SET DIC("W")="D DSPPAT^PSOTPCLP(+Y)"
+3 FOR
SET DIC("W")="D DSPPAT^PSOTPCLP(+Y)"
DO ^DIC
if Y'>0
QUIT
SET DFN=+Y
SET PTNM=$$GET1^DIQ(52.91,DFN,.01)
SET PATLST(PTNM,DFN)=""
Begin DoDot:1
+4 ;test death date
+5 SET XX=$$GET1^DIQ(2,DFN,.351)
IF XX'=""
Begin DoDot:2
+6 WRITE !!,"Sorry, ",PTNM," died ",XX,!
+7 KILL PATLST(PTNM,DFN)
HANG 3
End DoDot:2
QUIT
+8 ;test expired date
+9 SET EXPDTI=$$GET1^DIQ(52.91,DFN,2,"I")
+10 IF EXPDTI
IF DT>EXPDTI
Begin DoDot:2
+11 SET EXPDT=$$GET1^DIQ(52.91,+DFN,2)
+12 WRITE !,"Sorry, ",PTNM,"'s eligibility expired ",EXPDT,!
KILL PATLST(PTNM,DFN)
End DoDot:2
+13 ;check divisions required data
+14 SET DIVDA=$$GET1^DIQ(52.91,DFN,7,"I")
+15 SET XX=$$CHKINST^PSOTPCL(DIVDA)
IF XX
Begin DoDot:2
+16 WRITE !!,"Sorry, ",$$GET1^DIQ(52.91,DFN,7)," is missing required fields.",!!
+17 KILL PATLST(PTNM,DFN)
End DoDot:2
End DoDot:1
+18 ;
LST IF ($DATA(PATLST)<10)
WRITE !,"No Patients Selected - Quitting",!
HANG 3
SET PATLST=""
QUIT
+1 WRITE !!,"You have selected:",!
+2 SET PATNM=""
FOR I=1:1
SET PATNM=$ORDER(PATLST(PATNM))
if '$LENGTH(PATNM)
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(PATLST(PATNM,DFN))
if DFN'>0
QUIT
WRITE !,PATNM
DO DSPPAT(DFN)
IF '(I#20)
Begin DoDot:1
+3 KILL DIR
SET DIR(0)="E"
SET DIR("A")="<cr> - Continue ""^"" - Stop Display"
End DoDot:1
DO ^DIR
IF X["^"
QUIT
+4 ;
+5 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Is the above correct "
SET DIR("B")="YES"
DO ^DIR
+6 IF 'Y
GOTO PATSEL
+7 QUIT
DSPPAT(DFN) ; Display Division and expire date
+1 NEW DIVNM,EXPDT,PRTDT
+2 SET DIVNM=$$GET1^DIQ(52.91,DFN,7)
WRITE ?32,$EXTRACT(DIVNM,1,15)
+3 SET EXPDT=$$GET1^DIQ(52.91,DFN,2,"I")
+4 IF EXPDT
SET EXPDT=$$FMTE^XLFDT(EXPDT,"2D")
WRITE ?50,"Inact ",EXPDT
+5 SET PRTDT=$$GET1^DIQ(52.91,DFN,11,"I")
+6 IF PRTDT
SET PRTDT=$$FMTE^XLFDT(PRTDT,"2D")
WRITE ?66,"Prt ",PRTDT
+7 QUIT
DEVICE ;
+1 WRITE !,"Queueing is recommended",!
+2 SET %ZIS="Q"
DO ^%ZIS
+3 if POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET (PATLST,INST,PARAM)=""
+6 SET ZTRTN="DEQUE^PSOTPCLP"
SET ZTDESC="TPB PRINT PATIENT LETTERS"
+7 FOR XX="PATLST*","INST*","PARAM*"
SET ZTSAVE(XX)=""
+8 ;W ! ZW ZTRTN,ZTDESC,PATLST,INST,PARAM,ZTSAVE
+9 DO ^%ZTLOAD
+10 IF $GET(ZTSK)
WRITE !!,"Tasked with "_ZTSK
End DoDot:1
KILL ZTSK
GOTO EXIT
+11 ; (code falls through if not queued)
DEQUE ; DEQUE/PRINT LETTERS
+1 KILL ^TMP($JOB,"TPBLET")
+2 IF PARAM("SORT")="P"
GOTO SORTPAT
+3 SET DIVDA=0
FOR
SET DIVDA=$ORDER(INST(DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+4 SET DFN=0
FOR
SET DFN=$ORDER(^PS(52.91,"AC",DIVDA,DFN))
if DFN'>0
QUIT
Begin DoDot:2
+5 SET PTNM=$$GET1^DIQ(52.91,DFN,.01)
+6 SET EXPDTI=$PIECE(^PS(52.91,DFN,0),"^",3)
SET LTPDTI=$PIECE(^(0),"^",12)
+7 if EXPDTI
QUIT
+8 if $LENGTH($$GET1^DIQ(2,DFN,.351))
QUIT
+9 IF PARAM("LP")="N"
IF LTPDTI
QUIT
+10 IF PARAM("LP")="P"
IF 'LTPDTI
QUIT
+11 SET ^TMP($JOB,"TPBLET",DIVDA,PTNM,DFN)=""
End DoDot:2
End DoDot:1
+12 GOTO PRTLET
SORTPAT ; sort by patient
+1 KILL ^TMP($JOB,"TPBLET")
+2 SET PTNM=""
FOR
SET PTNM=$ORDER(PATLST(PTNM))
if PTNM=""
QUIT
Begin DoDot:1
+3 SET DFN=0
FOR
SET DFN=$ORDER(PATLST(PTNM,DFN))
if DFN'>0
QUIT
Begin DoDot:2
+4 SET DA0=^PS(52.91,DFN,0)
SET EXPDTI=$PIECE(DA0,"^",3)
SET LTPDTI=$PIECE(DA0,"^",12)
SET DIVDA=$PIECE(DA0,"^",8)
+5 if EXPDTI
QUIT
+6 IF PARAM("LP")="N"
IF LTPDTI
QUIT
+7 IF PARAM("LP")="P"
IF 'LTPDTI
QUIT
+8 SET ^TMP($JOB,"TPBLET",DIVDA,PTNM,DFN)=""
End DoDot:2
End DoDot:1
+9 GOTO PRTLET
+10 QUIT
PRTLET ; pull DIVDAs and DFNs from ^TMP($J,"TPBLET",
+1 ; load letter body into TMP
DO LOADTMP^PSOTPCLW
+2 KILL DIVCNT
+3 SET DIVDA=0
FOR
SET DIVDA=$ORDER(^TMP($JOB,"TPBLET",DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+4 SET XX=$$CHKINST^PSOTPCL(DIVDA)
IF XX
SET DIVCNT(DIVDA)=0
QUIT
+5 ;GETDIV(DIVDA) ;load institution/parent data for print
DO DIV
+6 SET PTNM=""
FOR
SET PTNM=$ORDER(^TMP($JOB,"TPBLET",DIVDA,PTNM))
if PTNM=""
QUIT
Begin DoDot:2
+7 SET DFN=0
+8 FOR
SET DFN=$ORDER(^TMP($JOB,"TPBLET",DIVDA,PTNM,DFN))
if DFN'>0
QUIT
Begin DoDot:3
+9 SET DIVCNT(DIVDA)=$GET(DIVCNT(DIVDA))+1
+10 DO LETTER(DFN)
+11 ;set print date
SET $PIECE(^PS(52.91,DFN,0),U,12)=DT
End DoDot:3
End DoDot:2
End DoDot:1
+12 ; summary of printing
+13 SET Y=DT
DO D^DIQ
SET SRDT=Y
+14 WRITE @IOF,!!,?10,"SUMMARY of TPB LETTER PRINTING ",SRDT
+15 WRITE !!
+16 IF '$DATA(DIVCNT)
WRITE !!,"NO DATA TO PRINT",!!
GOTO EXIT
+17 SET DIVDA=0
FOR
SET DIVDA=$ORDER(DIVCNT(DIVDA))
if DIVDA'>0
QUIT
Begin DoDot:1
+18 WRITE !,?5,$$GET1^DIQ(52.92,DIVDA,.01),?40,DIVCNT(DIVDA)
End DoDot:1
+19 WRITE !
+20 GOTO EXIT
+21 ;
LETTER(DFN) ; print letter , division variables information must be present
+1 USE IO
+2 DO GETPAT(DFN)
+3 ; patient inactive on printing date
IF EXPDT
IF EXPDT'>DT
QUIT
+4 DO HEADER
+5 FOR LN=1:1
if '$DATA(^TMP($JOB,"TPCLW","P1",LN))
QUIT
WRITE !,^(LN)
+6 WRITE ?30,"PHARMACY SERVICE",!,?30,DIVNM
+7 IF $LENGTH(MADD1)
Begin DoDot:1
+8 WRITE !,?30,MADD1
+9 if $LENGTH(MADD2)
WRITE !,?30,MADD2
+10 WRITE !,?30,MCITY,", ",MSTATE," ",MZIP
End DoDot:1
IF 1
+11 IF '$TEST
WRITE !,?30,ADD1
Begin DoDot:1
+12 if $LENGTH(ADD2)
WRITE !,?30,ADD2
+13 WRITE !,?30,CITY,", ",STATE," ",ZIP
End DoDot:1
+14 FOR LN=1:1
if '$DATA(^TMP($JOB,"TPCLW","P2",LN))
QUIT
WRITE !,^(LN)
+15 WRITE " ",PHN1
if $LENGTH(PHN2)
WRITE ", or ",PHN2
WRITE ".",!
+16 FOR LN=1:1
if '$DATA(^TMP($JOB,"TPCLW","P3",LN))
QUIT
if LN>1
WRITE !
WRITE ^(LN)
+17 WRITE !!!!,?4,SIG1
if $LENGTH(SIG2)
WRITE !,?4,SIG2
if $LENGTH(SIG3)
WRITE !,?4,SIG3
+18 WRITE !
+19 QUIT
GETPAT(DFN) ;GET PATIENT DATA
+1 KILL PTNM,EXPDT,SRANAME,TITLE,SRNM,PTSTATE,VADM,VAPA
+2 SET PTNM=$$GET1^DIQ(52.91,DFN,.01)
SET EXPDT=$$GET1^DIQ(52.91,DFN,2,"I")
+3 ;I EXPDT,DT'>EXPDT Q
+4 DO DEM^VADPT
DO ADD^VADPT
+5 SET PTLNM=$PIECE(PTNM,",")
SET PTXNM=$PIECE(PTNM,",")
+6 SET SRANAME=$PIECE(VADM(1),"^")
SET X=$PIECE(SRANAME,",")
SET Y=$EXTRACT(X)_$TRANSLATE($EXTRACT(X,2,$LENGTH(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+7 SET TITLE=$SELECT($PIECE(VADM(5),"^")="F":"Ms. ",1:"Mr. ")
SET SRANAME=TITLE_Y
+8 SET Y=DT
DO D^DIQ
SET SRDT=Y
+9 SET SEX=$PIECE(VADM(5),"^")
+10 SET SRNM=$PIECE(VADM(1),",",2)_" "_$PIECE(VADM(1),",")
+11 SET PADD1=$GET(VAPA(1))
SET PADD2=$GET(VAPA(2))
SET PADD3=$GET(VAPA(3))
+12 SET PCITY=$GET(VAPA(4))
SET PTSTATE=$PIECE($GET(VAPA(5)),U,2)
SET PZIP=$GET(VAPA(6))
+13 NEW PSOBADR,PSOTEMP
+14 SET PSOBADR=$$BADADR^DGUTL3(DFN)
IF PSOBADR
SET PSOTEMP=$$CHKTEMP^PSOBAI(DFN)
Begin DoDot:1
+15 IF 'PSOTEMP
SET PADD1="** BAD ADDRESS INDICATED **"
SET PADD2=""
SET PADD3=""
SET PCITY=""
SET PSTATE=""
SET PZIP=""
End DoDot:1
CCADD ; Get Confidential Correspondence Address if one is active
+1 ; and has the category "all other".
+2 ;
+3 ; See if CC address exists
+4 IF '$GET(VAPA(12))
QUIT
+5 ; code to check the CC category in the variable array VAPA(22)
+6 ; check catagories
+7 SET XX=0
FOR CC=1,2,5
IF $PIECE($GET(VAPA(22,CC)),U,3)="Y"
SET XX=1
+8 if 'XX
QUIT
+9 SET SRCCADD=1
+10 if $GET(VAPA(17))
SET PTSTATE=$PIECE(^DIC(5,$PIECE(VAPA(17),"^"),0),"^",2)
+11 SET PADD1=$GET(VAPA(13))
SET PADD2=$GET(VAPA(14))
SET PADD3=$GET(VAPA(15))
+12 SET PCITY=$GET(VAPA(16))
SET PTSTAT=$PIECE(VAPA(17),U,2)
SET PZIP=$PIECE(VAPA(18),U,2)
+13 QUIT
+1 USE IO
+2 WRITE @IOF
+3 WRITE !!,?(80-$LENGTH(DIVNM))\2,DIVNM
+4 WRITE !,?(80-$LENGTH(ADD1))\2,ADD1
+5 if $LENGTH(ADD2)
WRITE !,?(80-$LENGTH(ADD2))\2,ADD2
+6 SET XX=CITY_", "_STATE_" "_ZIP
+7 WRITE !,?(80-$LENGTH(XX))\2,XX
+8 FOR Y=$Y:1:10
WRITE !
+9 WRITE !,?4,SRNM,?65,SRDT,!,?4,PADD1
IF PADD2'=""
WRITE !,?4,PADD2
IF PADD3'=""
WRITE !,?4,VAPA(3)
+10 if PCITY'=""
WRITE !,?4,PCITY_", "_PTSTATE_" "_PZIP
WRITE !!!
+11 QUIT
DIV DO GETDIV(DIVDA)
+1 IF $LENGTH(PARDIV)
SET DIVDA2=$$GET1^DIQ(52.92,DIVDA,.02,"I")
DO GETDIV(DIVDA2)
+2 QUIT
GETDIV(DIVDA) ; GET DIVISIONAL DATA
+1 KILL DIVNM,PARDIV,PHN1,PHN2,ADD1,ADD2,CITY,ZIP,STATE,MADD1,MADD2,MCITY,MZIP,SIG1,SIG2,SIG3
+2 ;
+3 FOR FLDX="DIVNM^.01","PARDIV^.02","PHN1^.03","PHN2^.04","ADD1^.05","ADD2^.06","CITY^.07","ZIP^.08","STATE^.09"
DO GET1(52.92,DIVDA,FLDX)
+4 ;
+5 FOR FLDX="MADD1^1.01","MADD2^1.02","MCITY^1.03","MSTATE^1.04","MZIP^1.05","SIG1^2.01","SIG2^2.02","SIG3^2.03"
DO GET1(52.92,DIVDA,FLDX)
+6 ;
+7 QUIT
GET1(FILE,FLIEN,FLDX) ; "Variable^FLD" load variable = FILE,FLD
+1 NEW VAR
SET VAR=$PIECE(FLDX,"^")
SET FLD=$PIECE(FLDX,"^",2)
SET @VAR=$$GET1^DIQ(FILE,FLIEN,FLD)
+2 QUIT
EXIT ;
+1 DO ^%ZISC
+2 IF $GET(ZTSK)
DO KILL^%ZTLOAD
+3 KILL ADD1,ADD2,CHK,CITY,DIV,DIVCNT,DIVDA,DIVDA2,DIVNM,DIVX
+4 KILL EXPDT,EXPDTI,FAC,FDA,FLD,FLDX,FILE,FLD,FLDX,FLIEN
+5 KILL I,INST,LN,LOCDA,LTPDTI,MADD1,MADD2,MCITY,MZIP,PAR,PARAM
+6 KILL PARDIV,PATLST,PATNM,PHN1,PHN2,POP,PRTDT,PSOSTOP,PTLNM,PTNM
+7 KILL PTSTATE,PTXNM,SEX,SIG1,SIG2,SIG3,SRNAME,SRDT,STATE,TITLE
+8 KILL VADM,VAPA,VAR,XFLD,XX,YFLD,YY,ZIP,ZTDESC
+9 KILL ^TMP($JOB,"TPBLET"),^TMP($JOB,"TPCLW")
+10 QUIT
LOAD KILL PATLST
SET DFN=0
FOR
SET DFN=$ORDER(^PS(52.91,DFN))
if DFN'>0
QUIT
SET PATLST($$GET1^DIQ(52.91,DFN,.01))=DFN
+1 QUIT
