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

SDRRTSK.m

Go to the documentation of this file.
  1. SDRRTSK ;10N20/MAH - RECALL LETTER PRINT TASK ;09/05/17
  1. ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
  1. ;THIS ROUTINE WILL PRINT LETTER FOR SELECTED METHOD OF PRINTING
  1. ;WILL LOOK AT CLINIC RECALL LOCATION
  1. ;
  1. ; SD*654
  1. ; - fixes incomplete Canadian address.
  1. ; - changes word 'card' to 'letter' in the message.
  1. ;
  1. DATE ;lOOKS TO SEE HOW MANY DAYS IN ADVANCE TO PRINT LETTER
  1. Q:'$D(^SD(403.53,0))
  1. S CRP=0
  1. F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
  1. .S TYPE=$P($G(^SD(403.53,CRP,0)),"^",2)
  1. .Q:TYPE["C"
  1. .S DATE=$P($G(^SD(403.53,CRP,0)),"^",4) Q:DATE="" ;IF NOT SET ROUTINE WILL QUIT
  1. .S X="T+"_DATE D ^%DT S (ZSDT,ZEDT)=Y K Y
  1. .S (PRT,TEAM)=0
  1. .F S TEAM=$O(^SD(403.55,"C",CRP,TEAM)) Q:TEAM="" S PRT=$P($G(^SD(403.55,TEAM,0)),"^",3) D
  1. ..Q:PRT=""
  1. ..S DA=PRT
  1. ..S DIC="^%ZIS(1,",DR=".01;1;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
  1. ..N IOP S IOP=$G(DPTR("3.5",DA,".01","I")) D ^%ZIS
  1. ..S PROV=0 F S PROV=$O(^SD(403.54,"C",TEAM,PROV)) Q:PROV="" D
  1. ...S (MESSAGE,D0,LETTER)=0 F S D0=$O(^SD(403.5,"C",PROV,D0)) Q:D0="" S (CLINIC,FAIL)=0 S CLINIC=$P($G(^SD(403.5,D0,0)),"^",2) D
  1. ....; SD*579 - Kill x-refs and quit if entry not exist
  1. ....I '$D(^SD(403.5,D0)) D KXREF Q
  1. ....S DTA=$G(^SD(403.5,D0,0))
  1. ....I CLINIC="" S MESSAGE="***NO CLINIC ON FILE**"
  1. ....I CLINIC'="" I '$D(^SD(403.52,"B",CLINIC)) S MESSAGE="***NO CLINIC LETTER ON FILE**" S FAIL=1
  1. ....I CLINIC'="",(FAIL=0) S ZDIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))
  1. ....S TIME=""
  1. ....I $P($G(^SD(403.5,D0,0)),"^",9)>45 S TIME=$P($G(^SD(403.5,D0,0)),"^",9) S TIME="**"_TIME_"**"
  1. ....S LAB=$S($P($G(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$P(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an appointment is made",1:"")
  1. ....S DFN=+DTA
  1. ....;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
  1. ....Q:$P(DTA,U,6)>ZEDT ;alb/sat 643
  1. ....Q:$P(DTA,U,10)'="" ;alb/sat 643
  1. ....Q:$$TESTPAT^VADPT(DFN)
  1. ....D ADD^VADPT,DEM^VADPT
  1. ....S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
  1. ....S PN=$P(VADM(1),U)
  1. ....I $G(VADM(6),U)'="" Q
  1. ....N CHECK
  1. ....I $$BADADR^DGUTL3(DFN) S CHECK=1 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D
  1. .....S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5
  1. .....S SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
  1. .....D ^XMD
  1. .....K XMY,XMSUB,XMTEXT,XMDUZ
  1. .....Q
  1. ....;ADDED THE DATE INFORMATION
  1. ....I '$D(CHECK) S $P(^SD(403.5,D0,0),"^",10)=DT ;NEW CODE
  1. ....Q:$D(CHECK)
  1. ....U IO
  1. ....; SD*579 - Add date printed and last 4
  1. ....S PRNDT=$TR($$FMTE^XLFDT(DT,"5DF")," ","0")
  1. ....S LAST4=$E($P(VA("BID"),U),1,4)
  1. ....W @IOF
  1. ....W !,?65,PRNDT
  1. ....W !,?65,$E(PN,1)_LAST4
  1. ....F L=1:1:9 W !
  1. ....; SD*579 - Fix suffix problem
  1. ....S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
  1. ....W !?20,PNAME
  1. ....D ADDR ; SD*654 fix incomplete addr
  1. ....I LETTER=0 W !!!!!,?25,MESSAGE
  1. ....I TIME'="" W !!!!?2,"**"_TIME
  1. ....I LAB'="" W !!!!!,?2,"*"_LAB
  1. ....W !!!
  1. ....S:'$D(MESSAGE) LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))
  1. ....I LETTER>0 S LINE=0 F S LINE=$O(^SD(403.52,LETTER,1,LINE)) Q:'LINE W !,?2,$P(^SD(403.52,LETTER,1,LINE,0),"^",1)
  1. ..D ^%ZISC
  1. K DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
  1. K MESSAGE,LETTER,PRNDT,LAST4,PNAME
  1. QUIT K DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,LAB,STATE
  1. K LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,PROV,TEAM,CRP,DATE,TYPE,SDRR,DPT,VA
  1. D KVAR^VADPT
  1. Q
  1. ;
  1. KXREF ; SD*579 - If entry not exist, kill all the x-refs.
  1. S STR="BCDE"
  1. F I=1:1:$L(STR) D
  1. .S X=$E(STR,I,I)
  1. .S N3=0 F S N3=$O(^SD(403.5,X,N3)) Q:N3'>0 D
  1. ..S N4=0 F S N4=$O(^SD(403.5,X,N3,N4)) Q:N4'>0 D
  1. ...I N4=D0 K ^SD(403.5,X,N3,N4)
  1. K I,STR,X,N3,N4
  1. Q
  1. ;
  1. ADDR ; SD*654 Patient address
  1. ; Change state to abbr.
  1. N SDRRIENS,SDRRX
  1. I $D(VAPA(5)) S SDRRIENS=+VAPA(5)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(5),U,2)=SDRRX
  1. I $D(VAPA(17)) S SDRRIENS=+VAPA(17)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(17),U,2)=SDRRX
  1. K SDRRIENS,SDRRX
  1. ;
  1. N SDRRACT1,SDRRACT2,LL
  1. ; Check Confidential Address Indicator (0=Inactive,1=Active)
  1. S SDRRACT1=VAPA(12),SDRRACT2=$P($G(VAPA(22,2)),U,3)
  1. ; If Confidential address is not active, print regular address
  1. I ($G(SDRRACT1)=0)!($G(SDRRACT2)'="Y") D
  1. . F LL=1:1:3 W:VAPA(LL)]"" !,?20,VAPA(LL)
  1. . ; If country is blank, display as USA
  1. . I (VAPA(25)="")!($P(VAPA(25),U,2)="UNITED STATES") D
  1. . . ; Display city, state, zip
  1. . . W !?20,VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
  1. . E D
  1. . . ; Display city, province, postal code
  1. . . W !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
  1. . ; Display country
  1. . W:($P(VAPA(25),U,2)'="UNITED STATES") !,?20,$P(VAPA(25),U,2)
  1. ; If Confidential address is active, print confidential address
  1. I $G(SDRRACT1)=1,$G(SDRRACT2)="Y" D
  1. . F LL=13:1:15 W:VAPA(LL)]"" !,?20,VAPA(LL) ;*685
  1. . I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
  1. . . W !,?20,VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
  1. . E D
  1. . . W !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
  1. . I ($P(VAPA(28),"^",2)'="UNITED STATES") W !?20,$P(VAPA(28),U,2)
  1. Q