SDEC40 ;ALB/SAT,WTC,LEG - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
;;5.3;Scheduling;**627,665,694,785,813**;Aug 13, 1993;Build 6
;
; ICR
; ---
; 7024 - #40.8
; 7025 - #43
; 7030 - #2 (appointment record)
; 7034 - DGNFUNC
; 10035 - #2 (demographics)
; 10060 - #200
; 10061 - VAPDT
;
Q
;
; APL - Print Appointment Letter
;
APPTLETR(SDECY,SDECAPID,LT) ;Print Appointment Letter
;APPTLETR(SDECY,SDECAPID,LT) external parameter tag is in SDEC
; SDECAPPT = Pointer to appointment in SDEC APPOINTMENT file 409.84
; LT = Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
; Called by SDEC PRINT APPT LETTER remote procedure
N SDECI,SDECNOD,SDECTMP,DFN,IN,RES,SCLT,SDC,SDLET,SDS,SDT,X1,X2,Y,TIMEZONE
N SDIV,SDFORM,SDNAM,SDSSN,VAPA
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00080ERRORID"_$C(30)
I '+SDECAPID D ERR^SDECERR("Invalid Appointment ID.") Q
I '$D(^SDEC(409.84,SDECAPID,0)) D ERR^SDECERR("Invalid Appointment ID.") Q
I $G(LT)="" S LT="P" ;D ERR^SDECERR("Invalid Letter Type.") Q
S SDECNOD=^SDEC(409.84,SDECAPID,0)
S SDT=$P(SDECNOD,U) ;Get appt time
S DFN=$P(SDECNOD,U,5) ;Get patient pointer to VA PATIENT (^DPT) file 2
S RES=$P(SDECNOD,U,7) S SDC=$P(^SDEC(409.831,RES,0),U,4) ;get resource and clinic
S SDS=^DPT(DFN,"S",SDT,0)
S SCLT=$S(LT="N":1,LT="P":2,LT="C":3,LT="A":4,1:"2") ;get storage position of LETTER pointer
S SDLET=$P($G(^SC(SDC,"LTR")),U,SCLT)
I SDLET="" D ERR^SDECERR($S(SCLT=1:"No-Show",SCLT=2:"Pre-Appointment",SCLT=3:"Clinic Cancellation",1:"Patient Cancellation")_" Letter not defined for Clinic "_$P(^SC(SDC,0),U)_".") Q ;LEG 5/17/2021 ; added missing space
S SDIV=$P(^SC(SDC,0),"^",15),SDIV=$S(SDIV:SDIV,1:$O(^DG(40.8,0)))
S SDFORM=$P($G(^DG(40.8,SDIV,"LTR")),U,1)
; data header
S ^TMP("SDEC",$J,0)="T00080TEXT"_$C(30)
D PRT(DFN,SDC,SDT,LT,SDLET,SDFORM)
D WRAPP(DFN,SDC,SDT,LT,SDLET)
D REST(DFN,SDC,SDT,LT,SDLET,SDFORM)
S SDECI=SDECI+1 S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(30,31)
Q
;
;
PRT(DFN,SDC,SD,LT,SDLET,SDFORM) ;
; DFN - pointer to PATIENT file 2
; SDC - pointer to HOSPITAL LOCATION file 44
; SD - appointment time in FM format
; LT - Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
; SDLET - pointer to LETTER file 407.5
;WRITE GREETING AND OPENING TEXT OF LETTER
N A,DPTNAME,IN,X,Y
S A=DFN
Q:DFN=""
Q:LT=""
S SDFORM=$G(SDFORM)
S Y=DT D DTS^SDUTL
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(64," ")_Y_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(64," ")_$$LAST4(A)_$C(13,10)
I 'SDFORM D
.F I=1:1:4 S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
.D ADDR
.F I=1:1:4 S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
;
S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_","
S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M")
;S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="Dear "_$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")_X_","_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="Dear "_X_","_$C(13,10) ;VSE-693;LEG 5/12/21
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
;loop and display initial section of Letter
S IN=0 F S IN=$O(^VA(407.5,SDLET,1,IN)) Q:IN'>0 D
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=^VA(407.5,SDLET,1,IN,0)_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
Q
;
WRAPP(DFN,SDC,SD,LT,SDLET) ;WRITE APPOINTMENT INFORMATION
N B,DOW,S,SDCL,SDDAT,SDHX,SDT0,SDTMP,SDX,SDX1,X
S SDX=SD,S=$G(^DPT(DFN,"S",SD,0)) ;alb/sat 665 add S
S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=" Clinic: "_SDCL D FORM ; SD*5.3*622 end changes
;
S SDX1=SDX S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM ;alb/sat 665
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10) ;alb/sat 665
S (SDX,X)=SDX1 Q
; SD*5.3*622 - add more detail for appointment and format it
FORM ;S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) ; See below wtc 6/7/18 694
;
; Change display time for noon and midnight from 12:00 PM to 12:00 Noon and 12:00 Midnight
;
S TIMEZONE=$$TIMEZONEDATA^SDESUTIL($G(SDC)),TIMEZONE=$P($G(TIMEZONE),U)
S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX ;
I $P(X,".",2)=12!($P(X,".",2)=24) S X="12:00 "_$S($P(X,".",2)=12:"N",1:"M") ;
E X ^DD("FUNC",2,1) ;
S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3))
I '$D(B) S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" Date/Time: "_DOW_" "_$J(SDDAT,12)_$S('$D(B)&$D(SDC):$J(SDT0,9),1:"")_" "_TIMEZONE_$C(13,10)
I '$D(B),$D(SDC) D
.S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" "_SDCL_$C(13,10)
; get default provider if defined for a given clinic, print it on the
; letter only if we have a YES on file, same for clinic location
; skip printing the provider label if the field is empty in file #44
N J,SDLOC,SDPROV,SDPRNM,SDTEL,SDTELEXT
S SDLOC=$P($G(^SC(+SDC,0)),"^",11) ; physical location of the clinic
;ajf ;050918 ;R16969456FY18
S SDTEL=$P($G(^SC(+SDC,99)),"^",1) ; telephone number of clinic
S SDTELEXT="" I SDTEL]"",$G(^SC(+SDC,99.1))]"" D
.S SDTELEXT=^SC(+SDC,99.1) ; telephone ext of clinic
; get default provider, if any
F J=0:0 S J=$O(^SC(+SDC,"PR",J)) Q:'J>0 I $P($G(^SC(+SDC,"PR",J,0)),U,2)=1 S SDPROV=+$P(^SC(+SDC,"PR",J,0),U,1)
I $D(SDC),'$D(B),$P($G(^VA(407.5,SDLET,3)),U,2)="Y" D
.I SDLOC]"" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" "_"Location: "_SDLOC_$C(13,10)
I $D(SDC),'$D(B),SDTEL]"" D
.S SDTMP=" Telephone: "_SDTEL
.I SDTELEXT]"" S SDTMP=SDTMP_" Telephone Ext.: "_SDTELEXT
.S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDTMP_$C(13,10)
I $D(SDPROV) D
.I $D(SDC),SDPROV>0 S SDPRNM=$P(^VA(200,SDPROV,0),U,1)
.I $D(SDC),'$D(B),$P($G(^VA(407.5,SDLET,3)),U,1)="Y" I SDPRNM]"" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" Provider: "_$G(SDPRNM)_$C(13,10)
; call handler for LAB, XRAY, and EKG tests
I $D(B) D TST
Q
REST(DFN,SDC,SD,LT,SDLET,SDFORM) ;WRITE THE REMAINDER OF LETTER
N A,Z5,I,IN,X
S A=DFN
S SDFORM=$G(SDFORM)
;loop and display final section of Letter
S IN=0 F S IN=$O(^VA(407.5,SDLET,2,IN)) Q:IN'>0 D
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=^VA(407.5,SDLET,2,IN,0)_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
D:SDFORM=1 ADDR
Q
ADDR K VAHOW S DFN=+A S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_$$FML^DGNFUNC(DFN)_$C(13,10)
I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")=""
S X1=DT,X2=5 D C^%DTC ;I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X
D ADD^VADPT D
.;CHANGE STATE TO ABBR.
.N SDIENS,X
.I $D(VAPA(5)) S SDIENS=+VAPA(5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(5),U,2)=X
.I $D(VAPA(17)) S SDIENS=+VAPA(17)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(VAPA(17),U,2)=X
.K SDIENS Q
N SDCCACT1,SDCCACT2,LL
S SDCCACT1=VAPA(12),SDCCACT2=$P($G(VAPA(22,2)),"^",3)
;if confidential address is not active for scheduling/appointment letters, print to regular address
I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D
.F LL=1:1:3 I VAPA(LL)]"" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(LL)_$C(13,10)
.;if country is blank display as USA
.I (VAPA(25)="")!($P(VAPA(25),"^",2)="UNITED STATES") D ;display city,state,zip
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)_$C(13,10)
.E D ;display postal code,city,province
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(24)_" "_VAPA(4)_" "_VAPA(23)_$C(13,10)
.I ($P(VAPA(25),"^",2)'="UNITED STATES") S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_$P(VAPA(25),U,2)_$C(13,10) ;display country
;if confidential address is active for scheduling/appointment letters, print to confidential address
I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D
.F LL=13:1:15 I VAPA(LL)]"" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(LL)_$C(13,10)
.I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)_$C(13,10)
.E D
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_VAPA(27)_" "_VAPA(16)_" "_VAPA(26)_$C(13,10)
.I ($P(VAPA(28),"^",2)'="UNITED STATES") S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(11," ")_$P(VAPA(28),U,2)_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
D KVAR^VADPT
Q
;
;
LAST4(DFN) ;Return patient "last four"
N SDX
S SDX=$G(^DPT(+DFN,0))
Q $E(SDX)_$E($P(SDX,U,9),6,9)
;
BADADD ;Print patients with a Bad Address Indicator
I '$D(^TMP($J,"BADADD")) Q
N SDHDR,SDHDR1
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(79,"*")_$C(13,10)
S SDHDR="BAD ADDRESS INDICATOR LIST" S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU((80-$L(SDHDR)/2)," ")_SDHDR_$C(13,10)
S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="Last 4"_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="of SSN "_"Patient Name"_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$FILL^SDECU(79,"*")_$C(13,10)
N SDNAM,SDDFN
S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D
. S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D
. . S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$$LAST4(SDDFN)_" "_SDNAM_$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10)
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDHDR1_$C(13,10)
Q
;
TST ; SD*5.3*622 - handle scheduled tests
;S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10) ;alb/sat 665 remove blank line
I ($L(SDCL)=3&($E(SDCL,1,3)="LAB")) S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)_$C(13,10) ;alb/sat 665 add space
I ($L(SDCL)=4&($E(SDCL,1,4)="XRAY")) S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)_$C(13,10)
I ($L(SDCL)=3&($E(SDCL,1,3)="EKG")) S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)_$C(13,10) ;alb/sat 665 add space
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC40 10576 printed Sep 23, 2025@20:26:59 Page 2
SDEC40 ;ALB/SAT,WTC,LEG - VISTA SCHEDULING RPCS ;Feb 12, 2020@15:22
+1 ;;5.3;Scheduling;**627,665,694,785,813**;Aug 13, 1993;Build 6
+2 ;
+3 ; ICR
+4 ; ---
+5 ; 7024 - #40.8
+6 ; 7025 - #43
+7 ; 7030 - #2 (appointment record)
+8 ; 7034 - DGNFUNC
+9 ; 10035 - #2 (demographics)
+10 ; 10060 - #200
+11 ; 10061 - VAPDT
+12 ;
+13 QUIT
+14 ;
+15 ; APL - Print Appointment Letter
+16 ;
APPTLETR(SDECY,SDECAPID,LT) ;Print Appointment Letter
+1 ;APPTLETR(SDECY,SDECAPID,LT) external parameter tag is in SDEC
+2 ; SDECAPPT = Pointer to appointment in SDEC APPOINTMENT file 409.84
+3 ; LT = Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
+4 ; Called by SDEC PRINT APPT LETTER remote procedure
+5 NEW SDECI,SDECNOD,SDECTMP,DFN,IN,RES,SCLT,SDC,SDLET,SDS,SDT,X1,X2,Y,TIMEZONE
+6 NEW SDIV,SDFORM,SDNAM,SDSSN,VAPA
+7 SET SDECI=0
+8 KILL ^TMP("SDEC",$JOB)
+9 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+10 SET ^TMP("SDEC",$JOB,0)="T00080ERRORID"_$CHAR(30)
+11 IF '+SDECAPID
DO ERR^SDECERR("Invalid Appointment ID.")
QUIT
+12 IF '$DATA(^SDEC(409.84,SDECAPID,0))
DO ERR^SDECERR("Invalid Appointment ID.")
QUIT
+13 ;D ERR^SDECERR("Invalid Letter Type.") Q
IF $GET(LT)=""
SET LT="P"
+14 SET SDECNOD=^SDEC(409.84,SDECAPID,0)
+15 ;Get appt time
SET SDT=$PIECE(SDECNOD,U)
+16 ;Get patient pointer to VA PATIENT (^DPT) file 2
SET DFN=$PIECE(SDECNOD,U,5)
+17 ;get resource and clinic
SET RES=$PIECE(SDECNOD,U,7)
SET SDC=$PIECE(^SDEC(409.831,RES,0),U,4)
+18 SET SDS=^DPT(DFN,"S",SDT,0)
+19 ;get storage position of LETTER pointer
SET SCLT=$SELECT(LT="N":1,LT="P":2,LT="C":3,LT="A":4,1:"2")
+20 SET SDLET=$PIECE($GET(^SC(SDC,"LTR")),U,SCLT)
+21 ;LEG 5/17/2021 ; added missing space
IF SDLET=""
DO ERR^SDECERR($SELECT(SCLT=1:"No-Show",SCLT=2:"Pre-Appointment",SCLT=3:"Clinic Cancellation",1:"Patient Cancellation")_" Letter not defined for Clinic "_$PIECE(^SC(SDC,0),U)_".")
QUIT
+22 SET SDIV=$PIECE(^SC(SDC,0),"^",15)
SET SDIV=$SELECT(SDIV:SDIV,1:$ORDER(^DG(40.8,0)))
+23 SET SDFORM=$PIECE($GET(^DG(40.8,SDIV,"LTR")),U,1)
+24 ; data header
+25 SET ^TMP("SDEC",$JOB,0)="T00080TEXT"_$CHAR(30)
+26 DO PRT(DFN,SDC,SDT,LT,SDLET,SDFORM)
+27 DO WRAPP(DFN,SDC,SDT,LT,SDLET)
+28 DO REST(DFN,SDC,SDT,LT,SDLET,SDFORM)
+29 SET SDECI=SDECI+1
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(30,31)
+30 QUIT
+31 ;
+32 ;
PRT(DFN,SDC,SD,LT,SDLET,SDFORM) ;
+1 ; DFN - pointer to PATIENT file 2
+2 ; SDC - pointer to HOSPITAL LOCATION file 44
+3 ; SD - appointment time in FM format
+4 ; LT - Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
+5 ; SDLET - pointer to LETTER file 407.5
+6 ;WRITE GREETING AND OPENING TEXT OF LETTER
+7 NEW A,DPTNAME,IN,X,Y
+8 SET A=DFN
+9 if DFN=""
QUIT
+10 if LT=""
QUIT
+11 SET SDFORM=$GET(SDFORM)
+12 SET Y=DT
DO DTS^SDUTL
+13 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(64," ")_Y_$CHAR(13,10)
+14 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(64," ")_$$LAST4(A)_$CHAR(13,10)
+15 IF 'SDFORM
Begin DoDot:1
+16 FOR I=1:1:4
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+17 DO ADDR
+18 FOR I=1:1:4
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
End DoDot:1
+19 ;
+20 SET DPTNAME("FILE")=2
SET DPTNAME("FIELD")=".01"
SET DPTNAME("IENS")=(+A)_","
+21 SET X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M")
+22 ;S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)="Dear "_$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ")_X_","_$C(13,10)
+23 ;VSE-693;LEG 5/12/21
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="Dear "_X_","_$CHAR(13,10)
+24 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+25 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+26 ;loop and display initial section of Letter
+27 SET IN=0
FOR
SET IN=$ORDER(^VA(407.5,SDLET,1,IN))
if IN'>0
QUIT
Begin DoDot:1
+28 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=^VA(407.5,SDLET,1,IN,0)_$CHAR(13,10)
End DoDot:1
+29 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+30 QUIT
+31 ;
WRAPP(DFN,SDC,SD,LT,SDLET) ;WRITE APPOINTMENT INFORMATION
+1 NEW B,DOW,S,SDCL,SDDAT,SDHX,SDT0,SDTMP,SDX,SDX1,X
+2 ;alb/sat 665 add S
SET SDX=SD
SET S=$GET(^DPT(DFN,"S",SD,0))
+3 ; SD*5.3*622 end changes
SET SDCL=$PIECE(^SC(+SDC,0),"^",1)
SET SDCL=" Clinic: "_SDCL
DO FORM
+4 ;
+5 ;alb/sat 665
SET SDX1=SDX
if $DATA(SDS)
SET S=SDS
FOR B=3,4,5
IF $PIECE(S,"^",B)]""
SET SDCL=$SELECT(B=3:"LAB",B=4:"XRAY",1:"EKG")
SET SDX=$PIECE(S,"^",B)
DO FORM
+6 ;alb/sat 665
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+7 SET (SDX,X)=SDX1
QUIT
+8 ; SD*5.3*622 - add more detail for appointment and format it
FORM ;S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) ; See below wtc 6/7/18 694
+1 ;
+2 ; Change display time for noon and midnight from 12:00 PM to 12:00 Noon and 12:00 Midnight
+3 ;
+4 SET TIMEZONE=$$TIMEZONEDATA^SDESUTIL($GET(SDC))
SET TIMEZONE=$PIECE($GET(TIMEZONE),U)
+5 ;
if $DATA(SDX)
SET X=SDX
SET SDHX=X
DO DW^%DTC
SET DOW=X
SET X=SDHX
+6 ;
IF $PIECE(X,".",2)=12!($PIECE(X,".",2)=24)
SET X="12:00 "_$SELECT($PIECE(X,".",2)=12:"N",1:"M")
+7 ;
IF '$TEST
XECUTE ^DD("FUNC",2,1)
+8 SET SDT0=X
SET SDDAT=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$EXTRACT(SDHX,4,5))_" "_+$EXTRACT(SDHX,6,7)_", "_(1700+$EXTRACT(SDHX,1,3))
+9 IF '$DATA(B)
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" Date/Time: "_DOW_" "_$JUSTIFY(SDDAT,12)_$SELECT('$DATA(B)&$DATA(SDC):$JUSTIFY(SDT0,9),1:"")_" "_TIMEZONE_$CHAR(13,10)
+10 IF '$DATA(B)
IF $DATA(SDC)
Begin DoDot:1
+11 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" "_SDCL_$CHAR(13,10)
End DoDot:1
+12 ; get default provider if defined for a given clinic, print it on the
+13 ; letter only if we have a YES on file, same for clinic location
+14 ; skip printing the provider label if the field is empty in file #44
+15 NEW J,SDLOC,SDPROV,SDPRNM,SDTEL,SDTELEXT
+16 ; physical location of the clinic
SET SDLOC=$PIECE($GET(^SC(+SDC,0)),"^",11)
+17 ;ajf ;050918 ;R16969456FY18
+18 ; telephone number of clinic
SET SDTEL=$PIECE($GET(^SC(+SDC,99)),"^",1)
+19 SET SDTELEXT=""
IF SDTEL]""
IF $GET(^SC(+SDC,99.1))]""
Begin DoDot:1
+20 ; telephone ext of clinic
SET SDTELEXT=^SC(+SDC,99.1)
End DoDot:1
+21 ; get default provider, if any
+22 FOR J=0:0
SET J=$ORDER(^SC(+SDC,"PR",J))
if 'J>0
QUIT
IF $PIECE($GET(^SC(+SDC,"PR",J,0)),U,2)=1
SET SDPROV=+$PIECE(^SC(+SDC,"PR",J,0),U,1)
+23 IF $DATA(SDC)
IF '$DATA(B)
IF $PIECE($GET(^VA(407.5,SDLET,3)),U,2)="Y"
Begin DoDot:1
+24 IF SDLOC]""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" "_"Location: "_SDLOC_$CHAR(13,10)
End DoDot:1
+25 IF $DATA(SDC)
IF '$DATA(B)
IF SDTEL]""
Begin DoDot:1
+26 SET SDTMP=" Telephone: "_SDTEL
+27 IF SDTELEXT]""
SET SDTMP=SDTMP_" Telephone Ext.: "_SDTELEXT
+28 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDTMP_$CHAR(13,10)
End DoDot:1
+29 IF $DATA(SDPROV)
Begin DoDot:1
+30 IF $DATA(SDC)
IF SDPROV>0
SET SDPRNM=$PIECE(^VA(200,SDPROV,0),U,1)
+31 IF $DATA(SDC)
IF '$DATA(B)
IF $PIECE($GET(^VA(407.5,SDLET,3)),U,1)="Y"
IF SDPRNM]""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" Provider: "_$GET(SDPRNM)_$CHAR(13,10)
End DoDot:1
+32 ; call handler for LAB, XRAY, and EKG tests
+33 IF $DATA(B)
DO TST
+34 QUIT
REST(DFN,SDC,SD,LT,SDLET,SDFORM) ;WRITE THE REMAINDER OF LETTER
+1 NEW A,Z5,I,IN,X
+2 SET A=DFN
+3 SET SDFORM=$GET(SDFORM)
+4 ;loop and display final section of Letter
+5 SET IN=0
FOR
SET IN=$ORDER(^VA(407.5,SDLET,2,IN))
if IN'>0
QUIT
Begin DoDot:1
+6 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=^VA(407.5,SDLET,2,IN,0)_$CHAR(13,10)
End DoDot:1
+7 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+8 if SDFORM=1
DO ADDR
+9 QUIT
ADDR KILL VAHOW
SET DFN=+A
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_$$FML^DGNFUNC(DFN)_$CHAR(13,10)
+1 IF $DATA(^DG(43,1,"BT"))
IF '$PIECE(^("BT"),"^",3)
SET VAPA("P")=""
+2 ;I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X
SET X1=DT
SET X2=5
DO C^%DTC
+3 DO ADD^VADPT
Begin DoDot:1
+4 ;CHANGE STATE TO ABBR.
+5 NEW SDIENS,X
+6 IF $DATA(VAPA(5))
SET SDIENS=+VAPA(5)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(5),U,2)=X
+7 IF $DATA(VAPA(17))
SET SDIENS=+VAPA(17)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(17),U,2)=X
+8 KILL SDIENS
QUIT
End DoDot:1
+9 NEW SDCCACT1,SDCCACT2,LL
+10 SET SDCCACT1=VAPA(12)
SET SDCCACT2=$PIECE($GET(VAPA(22,2)),"^",3)
+11 ;if confidential address is not active for scheduling/appointment letters, print to regular address
+12 IF ($GET(SDCCACT1)=0)!($GET(SDCCACT2)'="Y")
Begin DoDot:1
+13 FOR LL=1:1:3
IF VAPA(LL)]""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(LL)_$CHAR(13,10)
+14 ;if country is blank display as USA
+15 ;display city,state,zip
IF (VAPA(25)="")!($PIECE(VAPA(25),"^",2)="UNITED STATES")
Begin DoDot:2
+16 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)_$CHAR(13,10)
End DoDot:2
+17 ;display postal code,city,province
IF '$TEST
Begin DoDot:2
+18 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(24)_" "_VAPA(4)_" "_VAPA(23)_$CHAR(13,10)
End DoDot:2
+19 ;display country
IF ($PIECE(VAPA(25),"^",2)'="UNITED STATES")
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_$PIECE(VAPA(25),U,2)_$CHAR(13,10)
End DoDot:1
+20 ;if confidential address is active for scheduling/appointment letters, print to confidential address
+21 IF $GET(SDCCACT1)=1
IF $GET(SDCCACT2)="Y"
Begin DoDot:1
+22 FOR LL=13:1:15
IF VAPA(LL)]""
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(LL)_$CHAR(13,10)
+23 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
Begin DoDot:2
+24 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)_$CHAR(13,10)
End DoDot:2
+25 IF '$TEST
Begin DoDot:2
+26 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_VAPA(27)_" "_VAPA(16)_" "_VAPA(26)_$CHAR(13,10)
End DoDot:2
+27 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(11," ")_$PIECE(VAPA(28),U,2)_$CHAR(13,10)
End DoDot:1
+28 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+29 DO KVAR^VADPT
+30 QUIT
+31 ;
+32 ;
LAST4(DFN) ;Return patient "last four"
+1 NEW SDX
+2 SET SDX=$GET(^DPT(+DFN,0))
+3 QUIT $EXTRACT(SDX)_$EXTRACT($PIECE(SDX,U,9),6,9)
+4 ;
BADADD ;Print patients with a Bad Address Indicator
+1 IF '$DATA(^TMP($JOB,"BADADD"))
QUIT
+2 NEW SDHDR,SDHDR1
+3 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(79,"*")_$CHAR(13,10)
+4 SET SDHDR="BAD ADDRESS INDICATOR LIST"
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU((80-$LENGTH(SDHDR)/2)," ")_SDHDR_$CHAR(13,10)
+5 SET SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
+6 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="Last 4"_$CHAR(13,10)
+7 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)="of SSN "_"Patient Name"_$CHAR(13,10)
+8 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$FILL^SDECU(79,"*")_$CHAR(13,10)
+9 NEW SDNAM,SDDFN
+10 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^TMP($JOB,"BADADD",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+11 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"BADADD",SDNAM,SDDFN))
if 'SDDFN
QUIT
Begin DoDot:2
+12 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$$LAST4(SDDFN)_" "_SDNAM_$CHAR(13,10)
End DoDot:2
End DoDot:1
+13 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+14 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=$CHAR(13,10)
+15 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDHDR1_$CHAR(13,10)
+16 QUIT
+17 ;
TST ; SD*5.3*622 - handle scheduled tests
+1 ;S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=$C(13,10) ;alb/sat 665 remove blank line
+2 ;alb/sat 665 add space
IF ($LENGTH(SDCL)=3&($EXTRACT(SDCL,1,3)="LAB"))
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)_$CHAR(13,10)
+3 IF ($LENGTH(SDCL)=4&($EXTRACT(SDCL,1,4)="XRAY"))
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)_$CHAR(13,10)
+4 ;alb/sat 665 add space
IF ($LENGTH(SDCL)=3&($EXTRACT(SDCL,1,3)="EKG"))
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)_$CHAR(13,10)
+5 QUIT
