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

PSOTPCLP.m

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