SDES2APTLETTER ;ALB/TJB,TJB,TJB - VISTA SCHEDULING RPCS - LETTER PRINT ; JAN 31, 2025
;;5.3;Scheduling;**895,898,899**;Aug 13, 1993;Build 2
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to DIVISION in ICR #7024
; Reference to PATIENT in ICR #7025
; SDES2 PRINT APPT LETTER
Q
; print single letter
; SDINPUT("Appointment IEN")=IEN of the Appointment from file 409.84
; SDINPUT("Letter Type")=Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
PRINTLETTER(RESULTS,SDCONTEXT,SDINPUT) ;
N APPTLIST,APPTIEN,ERRORS,GBL,LETTERS,LINE,LCNT,LETIEN,LTYPE
S APPTIEN=$G(SDINPUT("Appointment IEN")),LTYPE=$G(SDINPUT("Letter Type"))
; validate context array
D VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
I $D(ERRORS) S ERRORS("letters",1)="" D BUILDJSON^SDES2JSON(.RESULTS,.ERRORS) Q
S LETIEN=$$VALLETTYPE(.ERRORS,LTYPE)
D VALAPPT(.ERRORS,APPTIEN,LTYPE)
I $D(ERRORS) D Q
. S ERRORS("letters",1)=""
. D BUILDJSON^SDES2JSON(.RESULTS,.ERRORS)
D APPTLETTER(.GBL,APPTIEN,LTYPE)
M LETTERS("letters",1)=@GBL
S LETTERS("letters",1,"appointmentID")=APPTIEN
I $D(ERRORS) M LETTERS=ERRORS
D BUILDJSON^SDES2JSON(.RESULTS,.LETTERS)
Q
; print multiple letters
; SDES2 PRINT APPT LETTERS
; SDINPUT("Appointment IEN",IEN)="" IEN of the Appointment from file 409.84
; SDINPUT("Letter Type")=Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
PRINTLETTERS(RESULTS,SDCONTEXT,SDINPUT) ;
N APPTIEN,ERRORS,LETIEN,LCNT,GBL,LETTERS,LINE,LTYPE
; validate context array
D VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
I $D(ERRORS) S ERRORS("letters",1)="" D BUILDJSON^SDES2JSON(.RESULTS,.ERRORS) Q
I '$O(SDINPUT("Appointment IEN","")) D
. D ERRLOG^SDES2JSON(.ERRORS,254)
; All Letters to be produced are only one type
S LTYPE=$G(SDINPUT("Letter Type"))
S LETIEN=$$VALLETTYPE(.ERRORS,LTYPE)
D VALAPPTS(.ERRORS,.SDINPUT,LTYPE)
I $D(ERRORS) S ERRORS("letters",1)="" D BUILDJSON^SDES2JSON(.RESULTS,.ERRORS) Q
S (APPTIEN,LCNT)=0
; build appointment letter for each appointment
F S APPTIEN=$O(SDINPUT("Appointment IEN",APPTIEN)) Q:'APPTIEN D
. D APPTLETTER(.GBL,APPTIEN,LTYPE)
. S LCNT=LCNT+1
. M LETTERS("letters",LCNT)=@GBL
. S LETTERS("letters",LCNT,"appointmentID")=APPTIEN
I '$D(LETTERS) S LETTERS("letters",1)=""
I $D(ERRORS) S ERRORS("letters",1)="" M LETTERS=ERRORS
D BUILDJSON^SDES2JSON(.RESULTS,.LETTERS)
Q
; validate appointment list
VALAPPTS(ERRORS,LIST,LTYPE) ;
N APPT
I '$O(LIST("Appointment IEN",0)) D ERRLOG^SDES2JSON(.ERRORS,254)
S APPT=0 F S APPT=$O(LIST("Appointment IEN",APPT)) Q:'APPT D VALAPPT(.ERRORS,APPT,LTYPE)
Q
; Validate appointment and check for proper letter on clinic
VALAPPT(ERRORS,APPTIEN,LTYPE) ;
N RES,CLINIEN,SCLETFLD,SDLET,LT,ERRTXT
S LT=$G(LTYPE)
I APPTIEN="" D ERRLOG^SDES2JSON(.ERRORS,14) Q
I APPTIEN'="",'$D(^SDEC(409.84,APPTIEN,0)) D ERRLOG^SDES2JSON(.ERRORS,15,APPTIEN) Q
S RES=$$GET1^DIQ(409.84,APPTIEN,.07,"I")
S CLINIEN=$$GET1^DIQ(409.831,RES,.04,"I")
S SCLETFLD=$S(LT="N":2508,LT="P":2509,LT="C":2510,LT="A":2511,1:2509)
S SDLET=$$GET1^DIQ(44,CLINIEN,SCLETFLD,"I")
I SDLET="" D Q
. S ERRTXT=$S(LT="N":"No-Show",LT="P":"Pre-Appointment",LT="C":"Clinic Cancellation",1:"Patient Cancellation")_" Letter not defined for Clinic "_$$GET1^DIQ(44,CLINIEN,.01,"E")
. D ERRLOG^SDES2JSON(.ERRORS,227,ERRTXT)
Q
; validate letter type
VALLETTYPE(ERRORS,LTYPE) ;
N LIEN,RESOURCE,CLIN
I '$L(LTYPE) D ERRLOG^SDES2JSON(.ERRORS,228) Q "" ; missing letter type
I '$D(^VA(407.6,"B",LTYPE)) D ERRLOG^SDES2JSON(.ERRORS,226,LTYPE) Q "" ;Invalid letter type.
S LIEN=$$FIND1^DIC(407.6,,"B",LTYPE)
Q LIEN
; print single appointment letter
APPTLETTER(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
;
N SDECI,DFN,RES,CLINICIEN,SDLET,SDT,X1,X2,Y,TIMEZONE
N SDIV,SDFORM,SDNAM,SDECDATA,SCLETFLD,ERRTXT
S SDECI=0
K ^TMP("SDEC_COMP",$J)
S SDECY=$NA(^TMP("SDEC_COMP",$J))
D GETS^DIQ(409.84,SDECAPID_",",".01;.05;.07","I","SDECDATA")
S SDT=$G(SDECDATA(409.84,SDECAPID_",",.01,"I"))
S DFN=$G(SDECDATA(409.84,SDECAPID_",",.05,"I"))
S RES=$G(SDECDATA(409.84,SDECAPID_",",.07,"I"))
S CLINICIEN=$$GET1^DIQ(409.831,RES,.04,"I")
S SCLETFLD=$S(LT="N":2508,LT="P":2509,LT="C":2510,LT="A":2511,1:2509)
S SDLET=$$GET1^DIQ(44,CLINICIEN,SCLETFLD,"I")
S SDIV=$$GET1^DIQ(44,CLINICIEN,3.5,"I")
S SDIV=$S(SDIV:SDIV,1:$O(^DG(40.8,0)))
; address location on letters 1 - bottom, 0 - top
S SDFORM=$$GET1^DIQ(40.8,SDIV,30.01,"I")
; data header
D PRT(DFN,CLINICIEN,SDT,LT,SDLET,SDFORM)
D WRAPP(DFN,CLINICIEN,SDT,LT,SDLET)
D REST(DFN,CLINICIEN,SDT,LT,SDLET,SDFORM)
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
; SDFORM - address location on letters (1 - bottom, 0 - top)
;WRITE GREETING AND OPENING TEXT OF LETTER
N DPTNAME,INITSEC,X,Y
Q:DFN=""
Q:LT=""
S SDFORM=$G(SDFORM)
S Y=DT
S Y=$TR($$FMTE^XLFDT(Y,"5DF")," ","0")
S SDECI=SDECI+1 S ^TMP("SDEC_COMP",$J,"topSection",SDECI)=$$FILL(64," ")_Y
S SDECI=SDECI+1 S ^TMP("SDEC_COMP",$J,"topSection",SDECI)=$$FILL(64," ")_$$LILAST4(DFN)
I 'SDFORM D ADDR(DFN)
;
S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+DFN)_","
S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M")
S SDECI=SDECI+1 S ^TMP("SDEC_COMP",$J,"salutation",SDECI)="Dear "_X_"," ;VSE-693;LEG 5/12/21
;loop and display initial section of Letter
S INITSEC=0 F S INITSEC=$O(^VA(407.5,SDLET,1,INITSEC)) Q:INITSEC'>0 D
. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"initialParagraph",SDECI)=$$GET1^DIQ(407.52,INITSEC_","_SDLET_",",.01,"E")
Q
;
WRAPP(DFN,SDC,SD,LT,SDLET) ;WRITE APPOINTMENT INFORMATION
N SDCL,SDDAT,SDHX,SDX,SDX1,X,PTAPPIENS
S SDX=SD
S SDCL=$$GET1^DIQ(44,+SDC,.01,"E")
S SDCL=" Clinic: "_SDCL D FORM(SDC,SDCL,SDX,,SDLET) ; SD*5.3*622 end changes
S SDX1=SDX
S PTAPPIENS=SD_","_DFN_","
I $$GET1^DIQ(2.98,PTAPPIENS,5,"I")]"" D
.S SDCL="LAB",SDX=$$GET1^DIQ(2.98,PTAPPIENS,5,"I") D FORM(SDC,SDCL,SDX,1)
I $$GET1^DIQ(2.98,PTAPPIENS,6,"I")]"" D
.S SDCL="XRAY",SDX=$$GET1^DIQ(2.98,PTAPPIENS,6,"I") D FORM(SDC,SDCL,SDX,1)
I $$GET1^DIQ(2.98,PTAPPIENS,7,"I")]"" D
.S SDCL="EKG",SDX=$$GET1^DIQ(2.98,PTAPPIENS,7,"I") D FORM(SDC,SDCL,SDX,1)
S (SDX,X)=SDX1
Q
; SD*5.3*622 - add more detail for appointment and format it
; SDC - clinic ien
; SDCL - clinic name or xray/lab/ekg
; SDX - date/time
; LEXPROC - is only passed in when this is a lab/xray/ekg date
;
; Change display time for noon and midnight from 12:00 PM to 12:00 Noon and 12:00 Midnight
FORM(SDC,SDCL,SDX,LEXPROC,SDLET) ;
N TIMEZONE,X,J,SDLOC,SDPROV,SDPRNM,SDTEL,SDTELEXT,SDTMP,SDHX,SDT0,DOW
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(LEXPROC) D
.S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" Date/Time: "_DOW_" "_$J(SDDAT,12)_$S('$D(LEXPROC)&$D(SDC):$J(SDT0,9),1:"")_" "_TIMEZONE
I '$D(LEXPROC),$D(SDC) D
.S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" "_SDCL
; 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
S SDLOC=$$GET1^DIQ(44,+SDC,10,"I") ; physical location of the clinic
S SDTEL=$$GET1^DIQ(44,+SDC,99,"I") ; telephone number of clinic
S SDTELEXT="" I SDTEL]"",$$GET1^DIQ(44,+SDC,99.1,"I")]"" D
.S SDTELEXT=$$GET1^DIQ(44,+SDC,99.1,"I") ; telephone ext of clinic
; get default provider, if any
F J=0:0 S J=$O(^SC(+SDC,"PR",J)) Q:'J>0 D
. I $$GET1^DIQ(44.1,J_","_+SDC_",",.02,"I")'=1 Q
. S SDPROV=$$GET1^DIQ(44.1,J_","_+SDC_",",.01,"I")
I $D(SDC),'$D(LEXPROC),$$GET1^DIQ(407.5,SDLET,5,"I")="Y" D
. I SDLOC]"" S SDECI=SDECI+1 S ^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" "_"Location: "_SDLOC
I $D(SDC),'$D(LEXPROC),SDTEL]"" D
. S SDTMP=" Telephone: "_SDTEL
. I SDTELEXT]"" S SDTMP=SDTMP_" Telephone Ext.: "_SDTELEXT
. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=SDTMP
I $D(SDPROV) D
. I $D(SDC),SDPROV>0 S SDPRNM=$P(^VA(200,SDPROV,0),U,1)
. I $D(SDC),'$D(LEXPROC),$P($G(^VA(407.5,SDLET,3)),U,1)="Y" I SDPRNM]"" S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" Provider: "_$G(SDPRNM)
; call handler for LAB, XRAY, and EKG tests
I $D(LEXPROC) D TST(SDCL,DOW)
Q
REST(DFN,SDC,SD,LT,SDLET,SDFORM) ;WRITE THE REMAINDER OF LETTER
N FINSEC
;loop and display final section of Letter
S FINSEC=0 F S FINSEC=$O(^VA(407.5,SDLET,2,FINSEC)) Q:FINSEC'>0 D
. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"textClosing",SDECI)=$$GET1^DIQ(407.53,FINSEC_","_SDLET_",",.01,"E")
I SDFORM=1 D ADDR(DFN)
Q
ADDR(DFN) ;
K VAHOW
N SDIENS,X,SDCCACT1,SDCCACT2,LL,VAPA,VACNTRY
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_$$FML^DGNFUNC(DFN)
I $D(^DG(43,1,"BT")),'$$GET1^DIQ(43,1,722,"I") S VAPA("P")=""
D ADD^VADPT
;CHANGE STATE TO ABBR.
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
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,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(LL)
. ;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,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(4)_" "_$P(VAPA(5),U,2)_" "_$P(VAPA(11),U,2)
. E D ;display postal code,city,province
.. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(24)_" "_VAPA(4)_" "_VAPA(23)_$C(13,10)
. I ($P(VAPA(25),"^",2)'="UNITED STATES") S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_$P(VAPA(25),U,2) ;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,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(LL)
. I (VAPA(28)="")!($P(VAPA(28),"^",2)="UNITED STATES") D
.. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(16)_" "_$P(VAPA(17),U,2)_" "_$P(VAPA(18),U,2)
. E D
.. S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
. I ($P(VAPA(28),"^",2)'="UNITED STATES") S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"addressPatient",SDECI)=$$FILL(11," ")_$P(VAPA(28),U,2)
D KVAR^VADPT
Q
;
DTS(Y) ;
Q:'Y ""
Q $TR($$FMTE^XLFDT(Y,"5DF")," ","0")
;
BADADD ;Print patients with a Bad Address Indicator
I '$D(^TMP($J,"BADADD")) Q
N SDHDR,SDHDR1,SDNAM,SDDFN
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)=$$FILL(79,"*")
S SDHDR="BAD ADDRESS INDICATOR LIST" S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)=$$FILL((80-$L(SDHDR)/2)," ")_SDHDR
S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR."
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)="Last 4"
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)="of SSN "_"Patient Name"
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)=$$FILL(79,"*")
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,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)=$$LILAST4(SDDFN)_" "_SDNAM_$C(13,10)
S SDECI=SDECI+1,^TMP("SDEC_COMP",$J,"BadAddress",SDECI)=SDHDR1
Q
;
TST(SDCL,DOW) ; handle scheduled tests
I ($L(SDCL)=3&($E(SDCL,1,3)="LAB")) D
. S SDECI=SDECI+1
. S ^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
I ($L(SDCL)=4&($E(SDCL,1,4)="XRAY")) D
. S SDECI=SDECI+1
. S ^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
I ($L(SDCL)=3&($E(SDCL,1,3)="EKG")) D
. S SDECI=SDECI+1
. S ^TMP("SDEC_COMP",$J,"scheduledAppointments",SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$J(SDDAT,12)_" "_$J(SDT0,5)
Q
FILL(PADS,CHAR) ;pad string
N I,RET
S CHAR=$G(CHAR)
S:CHAR="" CHAR=" "
S RET=""
F I=1:1:PADS S RET=RET_CHAR
Q RET
LILAST4(DFN) ;Retrieve the first letter of the last name and append last 4 SSN of a patient
N LAST4SSN,LASTIN
S LASTIN=$E($$GET1^DIQ(2,DFN_",",.01,"E"),1,1)
S LAST4SSN=$$GET1^DIQ(2,DFN_",",.09,"E")
I LAST4SSN["P" S LAST4SSN=$E(LAST4SSN,6,10) Q LASTIN_LAST4SSN
S LAST4SSN=$E(LAST4SSN,6,9)
Q LASTIN_LAST4SSN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES2APTLETTER 13716 printed Mar 13, 2025@21:58:18 Page 2
SDES2APTLETTER ;ALB/TJB,TJB,TJB - VISTA SCHEDULING RPCS - LETTER PRINT ; JAN 31, 2025
+1 ;;5.3;Scheduling;**895,898,899**;Aug 13, 1993;Build 2
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to DIVISION in ICR #7024
+5 ; Reference to PATIENT in ICR #7025
+6 ; SDES2 PRINT APPT LETTER
+7 QUIT
+8 ; print single letter
+9 ; SDINPUT("Appointment IEN")=IEN of the Appointment from file 409.84
+10 ; SDINPUT("Letter Type")=Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
PRINTLETTER(RESULTS,SDCONTEXT,SDINPUT) ;
+1 NEW APPTLIST,APPTIEN,ERRORS,GBL,LETTERS,LINE,LCNT,LETIEN,LTYPE
+2 SET APPTIEN=$GET(SDINPUT("Appointment IEN"))
SET LTYPE=$GET(SDINPUT("Letter Type"))
+3 ; validate context array
+4 DO VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
+5 IF $DATA(ERRORS)
SET ERRORS("letters",1)=""
DO BUILDJSON^SDES2JSON(.RESULTS,.ERRORS)
QUIT
+6 SET LETIEN=$$VALLETTYPE(.ERRORS,LTYPE)
+7 DO VALAPPT(.ERRORS,APPTIEN,LTYPE)
+8 IF $DATA(ERRORS)
Begin DoDot:1
+9 SET ERRORS("letters",1)=""
+10 DO BUILDJSON^SDES2JSON(.RESULTS,.ERRORS)
End DoDot:1
QUIT
+11 DO APPTLETTER(.GBL,APPTIEN,LTYPE)
+12 MERGE LETTERS("letters",1)=@GBL
+13 SET LETTERS("letters",1,"appointmentID")=APPTIEN
+14 IF $DATA(ERRORS)
MERGE LETTERS=ERRORS
+15 DO BUILDJSON^SDES2JSON(.RESULTS,.LETTERS)
+16 QUIT
+17 ; print multiple letters
+18 ; SDES2 PRINT APPT LETTERS
+19 ; SDINPUT("Appointment IEN",IEN)="" IEN of the Appointment from file 409.84
+20 ; SDINPUT("Letter Type")=Letter type - "N"=No Show; "P"=Pre-Appointment; "A"=Cancelled by Patient; "C"=Cancelled by Clinic
PRINTLETTERS(RESULTS,SDCONTEXT,SDINPUT) ;
+1 NEW APPTIEN,ERRORS,LETIEN,LCNT,GBL,LETTERS,LINE,LTYPE
+2 ; validate context array
+3 DO VALCONTEXT^SDES2VALCONTEXT(.ERRORS,.SDCONTEXT)
+4 IF $DATA(ERRORS)
SET ERRORS("letters",1)=""
DO BUILDJSON^SDES2JSON(.RESULTS,.ERRORS)
QUIT
+5 IF '$ORDER(SDINPUT("Appointment IEN",""))
Begin DoDot:1
+6 DO ERRLOG^SDES2JSON(.ERRORS,254)
End DoDot:1
+7 ; All Letters to be produced are only one type
+8 SET LTYPE=$GET(SDINPUT("Letter Type"))
+9 SET LETIEN=$$VALLETTYPE(.ERRORS,LTYPE)
+10 DO VALAPPTS(.ERRORS,.SDINPUT,LTYPE)
+11 IF $DATA(ERRORS)
SET ERRORS("letters",1)=""
DO BUILDJSON^SDES2JSON(.RESULTS,.ERRORS)
QUIT
+12 SET (APPTIEN,LCNT)=0
+13 ; build appointment letter for each appointment
+14 FOR
SET APPTIEN=$ORDER(SDINPUT("Appointment IEN",APPTIEN))
if 'APPTIEN
QUIT
Begin DoDot:1
+15 DO APPTLETTER(.GBL,APPTIEN,LTYPE)
+16 SET LCNT=LCNT+1
+17 MERGE LETTERS("letters",LCNT)=@GBL
+18 SET LETTERS("letters",LCNT,"appointmentID")=APPTIEN
End DoDot:1
+19 IF '$DATA(LETTERS)
SET LETTERS("letters",1)=""
+20 IF $DATA(ERRORS)
SET ERRORS("letters",1)=""
MERGE LETTERS=ERRORS
+21 DO BUILDJSON^SDES2JSON(.RESULTS,.LETTERS)
+22 QUIT
+23 ; validate appointment list
VALAPPTS(ERRORS,LIST,LTYPE) ;
+1 NEW APPT
+2 IF '$ORDER(LIST("Appointment IEN",0))
DO ERRLOG^SDES2JSON(.ERRORS,254)
+3 SET APPT=0
FOR
SET APPT=$ORDER(LIST("Appointment IEN",APPT))
if 'APPT
QUIT
DO VALAPPT(.ERRORS,APPT,LTYPE)
+4 QUIT
+5 ; Validate appointment and check for proper letter on clinic
VALAPPT(ERRORS,APPTIEN,LTYPE) ;
+1 NEW RES,CLINIEN,SCLETFLD,SDLET,LT,ERRTXT
+2 SET LT=$GET(LTYPE)
+3 IF APPTIEN=""
DO ERRLOG^SDES2JSON(.ERRORS,14)
QUIT
+4 IF APPTIEN'=""
IF '$DATA(^SDEC(409.84,APPTIEN,0))
DO ERRLOG^SDES2JSON(.ERRORS,15,APPTIEN)
QUIT
+5 SET RES=$$GET1^DIQ(409.84,APPTIEN,.07,"I")
+6 SET CLINIEN=$$GET1^DIQ(409.831,RES,.04,"I")
+7 SET SCLETFLD=$SELECT(LT="N":2508,LT="P":2509,LT="C":2510,LT="A":2511,1:2509)
+8 SET SDLET=$$GET1^DIQ(44,CLINIEN,SCLETFLD,"I")
+9 IF SDLET=""
Begin DoDot:1
+10 SET ERRTXT=$SELECT(LT="N":"No-Show",LT="P":"Pre-Appointment",LT="C":"Clinic Cancellation",1:"Patient Cancellation")_" Letter not defined for Clinic "_$$GET1^DIQ(44,CLINIEN,.01,"E")
+11 DO ERRLOG^SDES2JSON(.ERRORS,227,ERRTXT)
End DoDot:1
QUIT
+12 QUIT
+13 ; validate letter type
VALLETTYPE(ERRORS,LTYPE) ;
+1 NEW LIEN,RESOURCE,CLIN
+2 ; missing letter type
IF '$LENGTH(LTYPE)
DO ERRLOG^SDES2JSON(.ERRORS,228)
QUIT ""
+3 ;Invalid letter type.
IF '$DATA(^VA(407.6,"B",LTYPE))
DO ERRLOG^SDES2JSON(.ERRORS,226,LTYPE)
QUIT ""
+4 SET LIEN=$$FIND1^DIC(407.6,,"B",LTYPE)
+5 QUIT LIEN
+6 ; print single appointment letter
APPTLETTER(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 ;
+5 NEW SDECI,DFN,RES,CLINICIEN,SDLET,SDT,X1,X2,Y,TIMEZONE
+6 NEW SDIV,SDFORM,SDNAM,SDECDATA,SCLETFLD,ERRTXT
+7 SET SDECI=0
+8 KILL ^TMP("SDEC_COMP",$JOB)
+9 SET SDECY=$NAME(^TMP("SDEC_COMP",$JOB))
+10 DO GETS^DIQ(409.84,SDECAPID_",",".01;.05;.07","I","SDECDATA")
+11 SET SDT=$GET(SDECDATA(409.84,SDECAPID_",",.01,"I"))
+12 SET DFN=$GET(SDECDATA(409.84,SDECAPID_",",.05,"I"))
+13 SET RES=$GET(SDECDATA(409.84,SDECAPID_",",.07,"I"))
+14 SET CLINICIEN=$$GET1^DIQ(409.831,RES,.04,"I")
+15 SET SCLETFLD=$SELECT(LT="N":2508,LT="P":2509,LT="C":2510,LT="A":2511,1:2509)
+16 SET SDLET=$$GET1^DIQ(44,CLINICIEN,SCLETFLD,"I")
+17 SET SDIV=$$GET1^DIQ(44,CLINICIEN,3.5,"I")
+18 SET SDIV=$SELECT(SDIV:SDIV,1:$ORDER(^DG(40.8,0)))
+19 ; address location on letters 1 - bottom, 0 - top
+20 SET SDFORM=$$GET1^DIQ(40.8,SDIV,30.01,"I")
+21 ; data header
+22 DO PRT(DFN,CLINICIEN,SDT,LT,SDLET,SDFORM)
+23 DO WRAPP(DFN,CLINICIEN,SDT,LT,SDLET)
+24 DO REST(DFN,CLINICIEN,SDT,LT,SDLET,SDFORM)
+25 QUIT
+26 ;
+27 ;
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 ; SDFORM - address location on letters (1 - bottom, 0 - top)
+7 ;WRITE GREETING AND OPENING TEXT OF LETTER
+8 NEW DPTNAME,INITSEC,X,Y
+9 if DFN=""
QUIT
+10 if LT=""
QUIT
+11 SET SDFORM=$GET(SDFORM)
+12 SET Y=DT
+13 SET Y=$TRANSLATE($$FMTE^XLFDT(Y,"5DF")," ","0")
+14 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"topSection",SDECI)=$$FILL(64," ")_Y
+15 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"topSection",SDECI)=$$FILL(64," ")_$$LILAST4(DFN)
+16 IF 'SDFORM
DO ADDR(DFN)
+17 ;
+18 SET DPTNAME("FILE")=2
SET DPTNAME("FIELD")=".01"
SET DPTNAME("IENS")=(+DFN)_","
+19 SET X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M")
+20 ;VSE-693;LEG 5/12/21
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"salutation",SDECI)="Dear "_X_","
+21 ;loop and display initial section of Letter
+22 SET INITSEC=0
FOR
SET INITSEC=$ORDER(^VA(407.5,SDLET,1,INITSEC))
if INITSEC'>0
QUIT
Begin DoDot:1
+23 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"initialParagraph",SDECI)=$$GET1^DIQ(407.52,INITSEC_","_SDLET_",",.01,"E")
End DoDot:1
+24 QUIT
+25 ;
WRAPP(DFN,SDC,SD,LT,SDLET) ;WRITE APPOINTMENT INFORMATION
+1 NEW SDCL,SDDAT,SDHX,SDX,SDX1,X,PTAPPIENS
+2 SET SDX=SD
+3 SET SDCL=$$GET1^DIQ(44,+SDC,.01,"E")
+4 ; SD*5.3*622 end changes
SET SDCL=" Clinic: "_SDCL
DO FORM(SDC,SDCL,SDX,,SDLET)
+5 SET SDX1=SDX
+6 SET PTAPPIENS=SD_","_DFN_","
+7 IF $$GET1^DIQ(2.98,PTAPPIENS,5,"I")]""
Begin DoDot:1
+8 SET SDCL="LAB"
SET SDX=$$GET1^DIQ(2.98,PTAPPIENS,5,"I")
DO FORM(SDC,SDCL,SDX,1)
End DoDot:1
+9 IF $$GET1^DIQ(2.98,PTAPPIENS,6,"I")]""
Begin DoDot:1
+10 SET SDCL="XRAY"
SET SDX=$$GET1^DIQ(2.98,PTAPPIENS,6,"I")
DO FORM(SDC,SDCL,SDX,1)
End DoDot:1
+11 IF $$GET1^DIQ(2.98,PTAPPIENS,7,"I")]""
Begin DoDot:1
+12 SET SDCL="EKG"
SET SDX=$$GET1^DIQ(2.98,PTAPPIENS,7,"I")
DO FORM(SDC,SDCL,SDX,1)
End DoDot:1
+13 SET (SDX,X)=SDX1
+14 QUIT
+15 ; SD*5.3*622 - add more detail for appointment and format it
+16 ; SDC - clinic ien
+17 ; SDCL - clinic name or xray/lab/ekg
+18 ; SDX - date/time
+19 ; LEXPROC - is only passed in when this is a lab/xray/ekg date
+20 ;
+21 ; Change display time for noon and midnight from 12:00 PM to 12:00 Noon and 12:00 Midnight
FORM(SDC,SDCL,SDX,LEXPROC,SDLET) ;
+1 NEW TIMEZONE,X,J,SDLOC,SDPROV,SDPRNM,SDTEL,SDTELEXT,SDTMP,SDHX,SDT0,DOW
+2 SET TIMEZONE=$$TIMEZONEDATA^SDESUTIL($GET(SDC))
SET TIMEZONE=$PIECE($GET(TIMEZONE),U)
+3 ;
if $DATA(SDX)
SET X=SDX
SET SDHX=X
DO DW^%DTC
SET DOW=X
SET X=SDHX
+4 ;
IF $PIECE(X,".",2)=12!($PIECE(X,".",2)=24)
SET X="12:00 "_$SELECT($PIECE(X,".",2)=12:"N",1:"M")
+5 ;
IF '$TEST
XECUTE ^DD("FUNC",2,1)
+6 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))
+7 IF '$DATA(LEXPROC)
Begin DoDot:1
+8 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" Date/Time: "_DOW_" "_$JUSTIFY(SDDAT,12)_$SELECT('$DATA(LEXPROC)&$DATA(SDC):$JUSTIFY(SDT0,9),1:"")_" "_TIMEZONE
End DoDot:1
+9 IF '$DATA(LEXPROC)
IF $DATA(SDC)
Begin DoDot:1
+10 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" "_SDCL
End DoDot:1
+11 ; get default provider if defined for a given clinic, print it on the
+12 ; letter only if we have a YES on file, same for clinic location
+13 ; skip printing the provider label if the field is empty in file #44
+14 ; physical location of the clinic
SET SDLOC=$$GET1^DIQ(44,+SDC,10,"I")
+15 ; telephone number of clinic
SET SDTEL=$$GET1^DIQ(44,+SDC,99,"I")
+16 SET SDTELEXT=""
IF SDTEL]""
IF $$GET1^DIQ(44,+SDC,99.1,"I")]""
Begin DoDot:1
+17 ; telephone ext of clinic
SET SDTELEXT=$$GET1^DIQ(44,+SDC,99.1,"I")
End DoDot:1
+18 ; get default provider, if any
+19 FOR J=0:0
SET J=$ORDER(^SC(+SDC,"PR",J))
if 'J>0
QUIT
Begin DoDot:1
+20 IF $$GET1^DIQ(44.1,J_","_+SDC_",",.02,"I")'=1
QUIT
+21 SET SDPROV=$$GET1^DIQ(44.1,J_","_+SDC_",",.01,"I")
End DoDot:1
+22 IF $DATA(SDC)
IF '$DATA(LEXPROC)
IF $$GET1^DIQ(407.5,SDLET,5,"I")="Y"
Begin DoDot:1
+23 IF SDLOC]""
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" "_"Location: "_SDLOC
End DoDot:1
+24 IF $DATA(SDC)
IF '$DATA(LEXPROC)
IF SDTEL]""
Begin DoDot:1
+25 SET SDTMP=" Telephone: "_SDTEL
+26 IF SDTELEXT]""
SET SDTMP=SDTMP_" Telephone Ext.: "_SDTELEXT
+27 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=SDTMP
End DoDot:1
+28 IF $DATA(SDPROV)
Begin DoDot:1
+29 IF $DATA(SDC)
IF SDPROV>0
SET SDPRNM=$PIECE(^VA(200,SDPROV,0),U,1)
+30 IF $DATA(SDC)
IF '$DATA(LEXPROC)
IF $PIECE($GET(^VA(407.5,SDLET,3)),U,1)="Y"
IF SDPRNM]""
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" Provider: "_$GET(SDPRNM)
End DoDot:1
+31 ; call handler for LAB, XRAY, and EKG tests
+32 IF $DATA(LEXPROC)
DO TST(SDCL,DOW)
+33 QUIT
REST(DFN,SDC,SD,LT,SDLET,SDFORM) ;WRITE THE REMAINDER OF LETTER
+1 NEW FINSEC
+2 ;loop and display final section of Letter
+3 SET FINSEC=0
FOR
SET FINSEC=$ORDER(^VA(407.5,SDLET,2,FINSEC))
if FINSEC'>0
QUIT
Begin DoDot:1
+4 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"textClosing",SDECI)=$$GET1^DIQ(407.53,FINSEC_","_SDLET_",",.01,"E")
End DoDot:1
+5 IF SDFORM=1
DO ADDR(DFN)
+6 QUIT
ADDR(DFN) ;
+1 KILL VAHOW
+2 NEW SDIENS,X,SDCCACT1,SDCCACT2,LL,VAPA,VACNTRY
+3 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_$$FML^DGNFUNC(DFN)
+4 IF $DATA(^DG(43,1,"BT"))
IF '$$GET1^DIQ(43,1,722,"I")
SET VAPA("P")=""
+5 DO ADD^VADPT
+6 ;CHANGE STATE TO ABBR.
+7 IF $DATA(VAPA(5))
SET SDIENS=+VAPA(5)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(5),U,2)=X
+8 IF $DATA(VAPA(17))
SET SDIENS=+VAPA(17)_","
SET X=$$GET1^DIQ(5,SDIENS,1)
SET $PIECE(VAPA(17),U,2)=X
+9 SET SDCCACT1=VAPA(12)
SET SDCCACT2=$PIECE($GET(VAPA(22,2)),"^",3)
+10 ;if confidential address is not active for scheduling/appointment letters, print to regular address
+11 IF ($GET(SDCCACT1)=0)!($GET(SDCCACT2)'="Y")
Begin DoDot:1
+12 FOR LL=1:1:3
IF VAPA(LL)]""
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(LL)
+13 ;if country is blank display as USA
+14 ;display city,state,zip
IF (VAPA(25)="")!($PIECE(VAPA(25),"^",2)="UNITED STATES")
Begin DoDot:2
+15 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(4)_" "_$PIECE(VAPA(5),U,2)_" "_$PIECE(VAPA(11),U,2)
End DoDot:2
+16 ;display postal code,city,province
IF '$TEST
Begin DoDot:2
+17 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(24)_" "_VAPA(4)_" "_VAPA(23)_$CHAR(13,10)
End DoDot:2
+18 ;display country
IF ($PIECE(VAPA(25),"^",2)'="UNITED STATES")
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_$PIECE(VAPA(25),U,2)
End DoDot:1
+19 ;if confidential address is active for scheduling/appointment letters, print to confidential address
+20 IF $GET(SDCCACT1)=1
IF $GET(SDCCACT2)="Y"
Begin DoDot:1
+21 FOR LL=13:1:15
IF VAPA(LL)]""
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(LL)
+22 IF (VAPA(28)="")!($PIECE(VAPA(28),"^",2)="UNITED STATES")
Begin DoDot:2
+23 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(16)_" "_$PIECE(VAPA(17),U,2)_" "_$PIECE(VAPA(18),U,2)
End DoDot:2
+24 IF '$TEST
Begin DoDot:2
+25 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_VAPA(27)_" "_VAPA(16)_" "_VAPA(26)
End DoDot:2
+26 IF ($PIECE(VAPA(28),"^",2)'="UNITED STATES")
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"addressPatient",SDECI)=$$FILL(11," ")_$PIECE(VAPA(28),U,2)
End DoDot:1
+27 DO KVAR^VADPT
+28 QUIT
+29 ;
DTS(Y) ;
+1 if 'Y
QUIT ""
+2 QUIT $TRANSLATE($$FMTE^XLFDT(Y,"5DF")," ","0")
+3 ;
BADADD ;Print patients with a Bad Address Indicator
+1 IF '$DATA(^TMP($JOB,"BADADD"))
QUIT
+2 NEW SDHDR,SDHDR1,SDNAM,SDDFN
+3 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)=$$FILL(79,"*")
+4 SET SDHDR="BAD ADDRESS INDICATOR LIST"
SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)=$$FILL((80-$LENGTH(SDHDR)/2)," ")_SDHDR
+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_COMP",$JOB,"BadAddress",SDECI)="Last 4"
+7 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)="of SSN "_"Patient Name"
+8 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)=$$FILL(79,"*")
+9 SET SDNAM=""
FOR
SET SDNAM=$ORDER(^TMP($JOB,"BADADD",SDNAM))
if SDNAM=""
QUIT
Begin DoDot:1
+10 SET SDDFN=0
FOR
SET SDDFN=$ORDER(^TMP($JOB,"BADADD",SDNAM,SDDFN))
if 'SDDFN
QUIT
Begin DoDot:2
+11 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)=$$LILAST4(SDDFN)_" "_SDNAM_$CHAR(13,10)
End DoDot:2
End DoDot:1
+12 SET SDECI=SDECI+1
SET ^TMP("SDEC_COMP",$JOB,"BadAddress",SDECI)=SDHDR1
+13 QUIT
+14 ;
TST(SDCL,DOW) ; handle scheduled tests
+1 IF ($LENGTH(SDCL)=3&($EXTRACT(SDCL,1,3)="LAB"))
Begin DoDot:1
+2 SET SDECI=SDECI+1
+3 SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)
End DoDot:1
+4 IF ($LENGTH(SDCL)=4&($EXTRACT(SDCL,1,4)="XRAY"))
Begin DoDot:1
+5 SET SDECI=SDECI+1
+6 SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)
End DoDot:1
+7 IF ($LENGTH(SDCL)=3&($EXTRACT(SDCL,1,3)="EKG"))
Begin DoDot:1
+8 SET SDECI=SDECI+1
+9 SET ^TMP("SDEC_COMP",$JOB,"scheduledAppointments",SDECI)=" "_SDCL_" SCHEDULED: "_DOW_" "_$JUSTIFY(SDDAT,12)_" "_$JUSTIFY(SDT0,5)
End DoDot:1
+10 QUIT
FILL(PADS,CHAR) ;pad string
+1 NEW I,RET
+2 SET CHAR=$GET(CHAR)
+3 if CHAR=""
SET CHAR=" "
+4 SET RET=""
+5 FOR I=1:1:PADS
SET RET=RET_CHAR
+6 QUIT RET
LILAST4(DFN) ;Retrieve the first letter of the last name and append last 4 SSN of a patient
+1 NEW LAST4SSN,LASTIN
+2 SET LASTIN=$EXTRACT($$GET1^DIQ(2,DFN_",",.01,"E"),1,1)
+3 SET LAST4SSN=$$GET1^DIQ(2,DFN_",",.09,"E")
+4 IF LAST4SSN["P"
SET LAST4SSN=$EXTRACT(LAST4SSN,6,10)
QUIT LASTIN_LAST4SSN
+5 SET LAST4SSN=$EXTRACT(LAST4SSN,6,9)
+6 QUIT LASTIN_LAST4SSN
+7 ;
