- SDRRTSK ;10N20/MAH - RECALL LETTER PRINT TASK ;09/05/17
- ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
- ;THIS ROUTINE WILL PRINT LETTER FOR SELECTED METHOD OF PRINTING
- ;WILL LOOK AT CLINIC RECALL LOCATION
- ;
- ; SD*654
- ; - fixes incomplete Canadian address.
- ; - changes word 'card' to 'letter' in the message.
- ;
- DATE ;lOOKS TO SEE HOW MANY DAYS IN ADVANCE TO PRINT LETTER
- Q:'$D(^SD(403.53,0))
- S CRP=0
- F S CRP=$O(^SD(403.53,CRP)) Q:'CRP D
- .S TYPE=$P($G(^SD(403.53,CRP,0)),"^",2)
- .Q:TYPE["C"
- .S DATE=$P($G(^SD(403.53,CRP,0)),"^",4) Q:DATE="" ;IF NOT SET ROUTINE WILL QUIT
- .S X="T+"_DATE D ^%DT S (ZSDT,ZEDT)=Y K Y
- .S (PRT,TEAM)=0
- .F S TEAM=$O(^SD(403.55,"C",CRP,TEAM)) Q:TEAM="" S PRT=$P($G(^SD(403.55,TEAM,0)),"^",3) D
- ..Q:PRT=""
- ..S DA=PRT
- ..S DIC="^%ZIS(1,",DR=".01;1;3",DIQ="DPTR",DIQ(0)="I" D EN^DIQ1
- ..N IOP S IOP=$G(DPTR("3.5",DA,".01","I")) D ^%ZIS
- ..S PROV=0 F S PROV=$O(^SD(403.54,"C",TEAM,PROV)) Q:PROV="" D
- ...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
- ....; SD*579 - Kill x-refs and quit if entry not exist
- ....I '$D(^SD(403.5,D0)) D KXREF Q
- ....S DTA=$G(^SD(403.5,D0,0))
- ....I CLINIC="" S MESSAGE="***NO CLINIC ON FILE**"
- ....I CLINIC'="" I '$D(^SD(403.52,"B",CLINIC)) S MESSAGE="***NO CLINIC LETTER ON FILE**" S FAIL=1
- ....I CLINIC'="",(FAIL=0) S ZDIV=CLINIC S LETTER=0,LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))
- ....S TIME=""
- ....I $P($G(^SD(403.5,D0,0)),"^",9)>45 S TIME=$P($G(^SD(403.5,D0,0)),"^",9) S TIME="**"_TIME_"**"
- ....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:"")
- ....S DFN=+DTA
- ....;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
- ....Q:$P(DTA,U,6)>ZEDT ;alb/sat 643
- ....Q:$P(DTA,U,10)'="" ;alb/sat 643
- ....Q:$$TESTPAT^VADPT(DFN)
- ....D ADD^VADPT,DEM^VADPT
- ....S STATE=$P(VAPA(5),"^",1),STATE=$$GET1^DIQ(5,STATE_",",1)
- ....S PN=$P(VADM(1),U)
- ....I $G(VADM(6),U)'="" Q
- ....N CHECK
- ....I $$BADADR^DGUTL3(DFN) S CHECK=1 S XMSUB="Bad Address for Recall Reminder Patient",XMTEXT="SDRR(" D
- .....S XMY("G.SDRR BAD ADDRESS")="",XMDUZ=.5
- .....S SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
- .....D ^XMD
- .....K XMY,XMSUB,XMTEXT,XMDUZ
- .....Q
- ....;ADDED THE DATE INFORMATION
- ....I '$D(CHECK) S $P(^SD(403.5,D0,0),"^",10)=DT ;NEW CODE
- ....Q:$D(CHECK)
- ....U IO
- ....; SD*579 - Add date printed and last 4
- ....S PRNDT=$TR($$FMTE^XLFDT(DT,"5DF")," ","0")
- ....S LAST4=$E($P(VA("BID"),U),1,4)
- ....W @IOF
- ....W !,?65,PRNDT
- ....W !,?65,$E(PN,1)_LAST4
- ....F L=1:1:9 W !
- ....; SD*579 - Fix suffix problem
- ....S PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
- ....W !?20,PNAME
- ....D ADDR ; SD*654 fix incomplete addr
- ....I LETTER=0 W !!!!!,?25,MESSAGE
- ....I TIME'="" W !!!!?2,"**"_TIME
- ....I LAB'="" W !!!!!,?2,"*"_LAB
- ....W !!!
- ....S:'$D(MESSAGE) LETTER=$O(^SD(403.52,"B",CLINIC,LETTER))
- ....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)
- ..D ^%ZISC
- K DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
- K MESSAGE,LETTER,PRNDT,LAST4,PNAME
- 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
- K LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,PROV,TEAM,CRP,DATE,TYPE,SDRR,DPT,VA
- D KVAR^VADPT
- Q
- ;
- KXREF ; SD*579 - If entry not exist, kill all the x-refs.
- S STR="BCDE"
- F I=1:1:$L(STR) D
- .S X=$E(STR,I,I)
- .S N3=0 F S N3=$O(^SD(403.5,X,N3)) Q:N3'>0 D
- ..S N4=0 F S N4=$O(^SD(403.5,X,N3,N4)) Q:N4'>0 D
- ...I N4=D0 K ^SD(403.5,X,N3,N4)
- K I,STR,X,N3,N4
- Q
- ;
- ADDR ; SD*654 Patient address
- ; Change state to abbr.
- N SDRRIENS,SDRRX
- I $D(VAPA(5)) S SDRRIENS=+VAPA(5)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(5),U,2)=SDRRX
- I $D(VAPA(17)) S SDRRIENS=+VAPA(17)_",",SDRRX=$$GET1^DIQ(5,SDRRIENS,1),$P(VAPA(17),U,2)=SDRRX
- K SDRRIENS,SDRRX
- ;
- N SDRRACT1,SDRRACT2,LL
- ; Check Confidential Address Indicator (0=Inactive,1=Active)
- S SDRRACT1=VAPA(12),SDRRACT2=$P($G(VAPA(22,2)),U,3)
- ; If Confidential address is not active, print regular address
- I ($G(SDRRACT1)=0)!($G(SDRRACT2)'="Y") D
- . F LL=1:1:3 W:VAPA(LL)]"" !,?20,VAPA(LL)
- . ; If country is blank, display as USA
- . I (VAPA(25)="")!($P(VAPA(25),U,2)="UNITED STATES") D
- . . ; Display city, state, zip
- . . W !?20,VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
- . E D
- . . ; Display city, province, postal code
- . . W !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
- . ; Display country
- . W:($P(VAPA(25),U,2)'="UNITED STATES") !,?20,$P(VAPA(25),U,2)
- ; If Confidential address is active, print confidential address
- I $G(SDRRACT1)=1,$G(SDRRACT2)="Y" D
- . F LL=13:1:15 W:VAPA(LL)]"" !,?20,VAPA(LL) ;*685
- . I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
- . . W !,?20,VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
- . E D
- . . W !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
- . I ($P(VAPA(28),"^",2)'="UNITED STATES") W !?20,$P(VAPA(28),U,2)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDRRTSK 5229 printed Feb 19, 2025@00:27:28 Page 2
- SDRRTSK ;10N20/MAH - RECALL LETTER PRINT TASK ;09/05/17
- +1 ;;5.3;Scheduling;**536,579,643,654,685**;Aug 13, 1993;Build 3
- +2 ;THIS ROUTINE WILL PRINT LETTER FOR SELECTED METHOD OF PRINTING
- +3 ;WILL LOOK AT CLINIC RECALL LOCATION
- +4 ;
- +5 ; SD*654
- +6 ; - fixes incomplete Canadian address.
- +7 ; - changes word 'card' to 'letter' in the message.
- +8 ;
- DATE ;lOOKS TO SEE HOW MANY DAYS IN ADVANCE TO PRINT LETTER
- +1 if '$DATA(^SD(403.53,0))
- QUIT
- +2 SET CRP=0
- +3 FOR
- SET CRP=$ORDER(^SD(403.53,CRP))
- if 'CRP
- QUIT
- Begin DoDot:1
- +4 SET TYPE=$PIECE($GET(^SD(403.53,CRP,0)),"^",2)
- +5 if TYPE["C"
- QUIT
- +6 ;IF NOT SET ROUTINE WILL QUIT
- SET DATE=$PIECE($GET(^SD(403.53,CRP,0)),"^",4)
- if DATE=""
- QUIT
- +7 SET X="T+"_DATE
- DO ^%DT
- SET (ZSDT,ZEDT)=Y
- KILL Y
- +8 SET (PRT,TEAM)=0
- +9 FOR
- SET TEAM=$ORDER(^SD(403.55,"C",CRP,TEAM))
- if TEAM=""
- QUIT
- SET PRT=$PIECE($GET(^SD(403.55,TEAM,0)),"^",3)
- Begin DoDot:2
- +10 if PRT=""
- QUIT
- +11 SET DA=PRT
- +12 SET DIC="^%ZIS(1,"
- SET DR=".01;1;3"
- SET DIQ="DPTR"
- SET DIQ(0)="I"
- DO EN^DIQ1
- +13 NEW IOP
- SET IOP=$GET(DPTR("3.5",DA,".01","I"))
- DO ^%ZIS
- +14 SET PROV=0
- FOR
- SET PROV=$ORDER(^SD(403.54,"C",TEAM,PROV))
- if PROV=""
- QUIT
- Begin DoDot:3
- +15 SET (MESSAGE,D0,LETTER)=0
- FOR
- SET D0=$ORDER(^SD(403.5,"C",PROV,D0))
- if D0=""
- QUIT
- SET (CLINIC,FAIL)=0
- SET CLINIC=$PIECE($GET(^SD(403.5,D0,0)),"^",2)
- Begin DoDot:4
- +16 ; SD*579 - Kill x-refs and quit if entry not exist
- +17 IF '$DATA(^SD(403.5,D0))
- DO KXREF
- QUIT
- +18 SET DTA=$GET(^SD(403.5,D0,0))
- +19 IF CLINIC=""
- SET MESSAGE="***NO CLINIC ON FILE**"
- +20 IF CLINIC'=""
- IF '$DATA(^SD(403.52,"B",CLINIC))
- SET MESSAGE="***NO CLINIC LETTER ON FILE**"
- SET FAIL=1
- +21 IF CLINIC'=""
- IF (FAIL=0)
- SET ZDIV=CLINIC
- SET LETTER=0
- SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))
- +22 SET TIME=""
- +23 IF $PIECE($GET(^SD(403.5,D0,0)),"^",9)>45
- SET TIME=$PIECE($GET(^SD(403.5,D0,0)),"^",9)
- SET TIME="**"_TIME_"**"
- +24 SET LAB=$SELECT($PIECE($GET(^SD(403.5,D0,0)),"^",8)="f":"Lab test(s) have been ordered that require you to FAST",$PIECE(^SD(403.5,D0,0),"^",8)="n":"Lab test(s) have been ordered, which need to be done before an a
- ppointment is made",1:"")
- +25 SET DFN=+DTA
- +26 ;Q:$P(DTA,U,6)<ZSDT!($P(DTA,U,6)>ZEDT)
- +27 ;alb/sat 643
- if $PIECE(DTA,U,6)>ZEDT
- QUIT
- +28 ;alb/sat 643
- if $PIECE(DTA,U,10)'=""
- QUIT
- +29 if $$TESTPAT^VADPT(DFN)
- QUIT
- +30 DO ADD^VADPT
- DO DEM^VADPT
- +31 SET STATE=$PIECE(VAPA(5),"^",1)
- SET STATE=$$GET1^DIQ(5,STATE_",",1)
- +32 SET PN=$PIECE(VADM(1),U)
- +33 IF $GET(VADM(6),U)'=""
- QUIT
- +34 NEW CHECK
- +35 IF $$BADADR^DGUTL3(DFN)
- SET CHECK=1
- SET XMSUB="Bad Address for Recall Reminder Patient"
- SET XMTEXT="SDRR("
- Begin DoDot:5
- +36 SET XMY("G.SDRR BAD ADDRESS")=""
- SET XMDUZ=.5
- +37 SET SDRR(1)="Bad Address - letter will not be printed for:"_" "_PN_" "_VA("BID")
- +38 DO ^XMD
- +39 KILL XMY,XMSUB,XMTEXT,XMDUZ
- +40 QUIT
- End DoDot:5
- +41 ;ADDED THE DATE INFORMATION
- +42 ;NEW CODE
- IF '$DATA(CHECK)
- SET $PIECE(^SD(403.5,D0,0),"^",10)=DT
- +43 if $DATA(CHECK)
- QUIT
- +44 USE IO
- +45 ; SD*579 - Add date printed and last 4
- +46 SET PRNDT=$TRANSLATE($$FMTE^XLFDT(DT,"5DF")," ","0")
- +47 SET LAST4=$EXTRACT($PIECE(VA("BID"),U),1,4)
- +48 WRITE @IOF
- +49 WRITE !,?65,PRNDT
- +50 WRITE !,?65,$EXTRACT(PN,1)_LAST4
- +51 FOR L=1:1:9
- WRITE !
- +52 ; SD*579 - Fix suffix problem
- +53 SET PNAME=$$NAMEFMT^XLFNAME(PN,"G","")
- +54 WRITE !?20,PNAME
- +55 ; SD*654 fix incomplete addr
- DO ADDR
- +56 IF LETTER=0
- WRITE !!!!!,?25,MESSAGE
- +57 IF TIME'=""
- WRITE !!!!?2,"**"_TIME
- +58 IF LAB'=""
- WRITE !!!!!,?2,"*"_LAB
- +59 WRITE !!!
- +60 if '$DATA(MESSAGE)
- SET LETTER=$ORDER(^SD(403.52,"B",CLINIC,LETTER))
- +61 IF LETTER>0
- SET LINE=0
- FOR
- SET LINE=$ORDER(^SD(403.52,LETTER,1,LINE))
- if 'LINE
- QUIT
- WRITE !,?2,$PIECE(^SD(403.52,LETTER,1,LINE,0),"^",1)
- End DoDot:4
- End DoDot:3
- +62 DO ^%ZISC
- End DoDot:2
- End DoDot:1
- +63 KILL DPTR,DEVSB,DEVSB1,DIQ,DEVSB1,DA,DA1,DR
- +64 KILL MESSAGE,LETTER,PRNDT,LAST4,PNAME
- QUIT KILL DEV,PRT,ADTA,D0,DFN,DIC,DIR,DIRUT,DTA,I,L,PN,POP,Y,ZDIV,ZEDT,ZPR,ZSDT,FAST,TIME,ACC,LAB,STATE
- +1 KILL LINE,LETTER,MESSAGE,TEST,CLINIC,DA,DATE,DEV1,DEVSB,DOD,FAIL,PROV,TEAM,X,PROV,TEAM,CRP,DATE,TYPE,SDRR,DPT,VA
- +2 DO KVAR^VADPT
- +3 QUIT
- +4 ;
- KXREF ; SD*579 - If entry not exist, kill all the x-refs.
- +1 SET STR="BCDE"
- +2 FOR I=1:1:$LENGTH(STR)
- Begin DoDot:1
- +3 SET X=$EXTRACT(STR,I,I)
- +4 SET N3=0
- FOR
- SET N3=$ORDER(^SD(403.5,X,N3))
- if N3'>0
- QUIT
- Begin DoDot:2
- +5 SET N4=0
- FOR
- SET N4=$ORDER(^SD(403.5,X,N3,N4))
- if N4'>0
- QUIT
- Begin DoDot:3
- +6 IF N4=D0
- KILL ^SD(403.5,X,N3,N4)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 KILL I,STR,X,N3,N4
- +8 QUIT
- +9 ;
- ADDR ; SD*654 Patient address
- +1 ; Change state to abbr.
- +2 NEW SDRRIENS,SDRRX
- +3 IF $DATA(VAPA(5))
- SET SDRRIENS=+VAPA(5)_","
- SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
- SET $PIECE(VAPA(5),U,2)=SDRRX
- +4 IF $DATA(VAPA(17))
- SET SDRRIENS=+VAPA(17)_","
- SET SDRRX=$$GET1^DIQ(5,SDRRIENS,1)
- SET $PIECE(VAPA(17),U,2)=SDRRX
- +5 KILL SDRRIENS,SDRRX
- +6 ;
- +7 NEW SDRRACT1,SDRRACT2,LL
- +8 ; Check Confidential Address Indicator (0=Inactive,1=Active)
- +9 SET SDRRACT1=VAPA(12)
- SET SDRRACT2=$PIECE($GET(VAPA(22,2)),U,3)
- +10 ; If Confidential address is not active, print regular address
- +11 IF ($GET(SDRRACT1)=0)!($GET(SDRRACT2)'="Y")
- Begin DoDot:1
- +12 FOR LL=1:1:3
- if VAPA(LL)]""
- WRITE !,?20,VAPA(LL)
- +13 ; If country is blank, display as USA
- +14 IF (VAPA(25)="")!($PIECE(VAPA(25),U,2)="UNITED STATES")
- Begin DoDot:2
- +15 ; Display city, state, zip
- +16 WRITE !?20,VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)
- End DoDot:2
- +17 IF '$TEST
- Begin DoDot:2
- +18 ; Display city, province, postal code
- +19 WRITE !?20,VAPA(4)_" "_VAPA(23)_" "_VAPA(24)
- End DoDot:2
- +20 ; Display country
- +21 if ($PIECE(VAPA(25),U,2)'="UNITED STATES")
- WRITE !,?20,$PIECE(VAPA(25),U,2)
- End DoDot:1
- +22 ; If Confidential address is active, print confidential address
- +23 IF $GET(SDRRACT1)=1
- IF $GET(SDRRACT2)="Y"
- Begin DoDot:1
- +24 ;*685
- FOR LL=13:1:15
- if VAPA(LL)]""
- WRITE !,?20,VAPA(LL)
- +25 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
- Begin DoDot:2
- +26 WRITE !,?20,VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)
- End DoDot:2
- +27 IF '$TEST
- Begin DoDot:2
- +28 WRITE !,?20,VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
- End DoDot:2
- +29 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
- WRITE !?20,$PIECE(VAPA(28),U,2)
- End DoDot:1
- +30 QUIT