SDECAR1 ;ALB/SAT,WTC,CT,LAB - VISTA SCHEDULING RPCS ;MAR 23, 2022@10:55
;;5.3;Scheduling;**627,642,658,686,694,745,813**;Aug 13, 1993;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified
;
Q
;
; Get SDEC APPOINTMENT REQUEST for all entries in the user's Institution
; where the Current Status is not C(losed).
ARGET(RET,ARIEN1,MAXREC,SDBEG,SDEND,DFN,LASTSUB,SDTOP,SVCL,DESDT,PRL,SVCR,SCVISIT,CLINIC,ORIGDT) ;Appt Req GET ;alb/sat 658 add SVCL-SCVISIT
ARGET1 ;
;29 SVCCONN - SERVICE CONNECTED? field .301 of the PATIENT file
;37 ARSVCCON - SERVICE CONNECTED PRIORITY field 15 of the SDEC APPT REQUEST file
;
N CLOSED,FNUM,NAME,DOB,SSN4,GENDER,ARORIGDT,ARINST,ARINSTNM,ARTYPE,ARTEAM,ARPOS
N ELIGIEN,ELIGNAME,FRULES,GLOREF,HRN,INSTIEN,INSTNAME,PRIGRP,SVCCONN,SVCCONNP,TYPEIEN,TYPENAME
N PCOUNTRY,SDSUB,SDTMP,SSN,ARSSIEN,ARSSNAME,ARCLIEN,ARCLNAME
N ARUSER,ARPRIO,ARREQBY,ARPROV,ARPROVNM,ARDAPTDT,ARCOMM,AREESTAT,ARUSRNM
N ARCLIENL,AREDT,ARIEN,PTINFOLSTA,ARDISPD,ARDISPU,ARDISPUN,ARSVCCON
N ARMAI,ARMAN,ARMAR,ARSTAT,ARSTOP,ARSTOPN,COUNT,DES,SDK,STR,SDRTMP
N PCITY,GAF,PSTATE,PZIP4,PADDRES1,PADDRES2,PADDRES3,PPC,PTPHONE,ARENPRI,ARASD,ARPC,ARDATA
N SDCL,SDI,SDJ,SDMTRC,SDPARENT,SDPS,SDSENS,SDDEMO,X,Y,%DT,APPTPTRS
N VAOSGUID ; wtc patch 686 3/23/18 added for VAOS requests
;
; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
;
N VAOSUSR ;
D OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST") ;
;
S RET="^TMP(""SDEC"","_$J_")"
K @RET
S FNUM=$$FNUM^SDECAR,COUNT=0
S MAXREC=+$G(MAXREC,50)
D HDR
S GLOREF=$NA(^SDEC(409.85,"C",DUZ(2)))
S FRULES=1
S ARIEN=0
;F S WLIEN=$O(@GLOREF@(WLIEN)) Q:'WLIEN D ONEPAT I MAXREC,COUNT'<MAXREC Q
S SDBEG=$G(SDBEG)
I SDBEG'="" S %DT="" S X=$P(SDBEG,"@",1) D ^%DT S SDBEG=Y I Y=-1 S SDBEG=3100101
I SDBEG="" S SDBEG=3100101
S SDEND=$G(SDEND)
I SDEND'="" S %DT="" S X=$P(SDEND,"@",1) D ^%DT S SDEND=Y I Y=-1 S SDEND=$$FMADD^XLFDT($E($$NOW^XLFDT,1,12),-90)
I SDEND="" S SDEND=$$FMADD^XLFDT($E($$NOW^XLFDT,1,12),-90)
S DFN=$G(DFN)
I DFN'="",'$D(^DPT(DFN,0)) S DFN=""
S LASTSUB=$S(DFN="":$G(LASTSUB),1:"")
S SDTOP=+$G(SDTOP)
;validate SVCL
S SVCL=$G(SVCL)
I SVCL'="" D
.F SDI=$L(SVCL,"|"):-1:1 S SVC=$P(SVCL,"|",SDI) D
..I (SVC="")!('$D(^DIC(40.7,+SVC,0))) S SVCL=$$PD^SDECUTL(SVCL,SDI,"|")
;validate DESDT
S DESDT=$G(DESDT)
;validate PRL
S PRL=$G(PRL)
I PRL'="" D
.N PR
.F SDI=$L(PRL,"|"):-1:1 S PR=$P(PRL,"|",SDI) D
..I "012345678"'[PR S PR=$E(PR,7)
..I "012345678"'[PR S PRL=$$PD^SDECUTL(PRL,SDI,"|")
;validate SVCR
S SVCR=$G(SVCR) S:SVCR'="" SVCR=$$UP^XLFSTR(SVCR)
I SVCR'="" S SVCR=$S(SVCR="Y":1,SVCR="N":0,SVCR="YES":1,SVCR="NO":0,1:"")
;validate SCVISIT
S SCVISIT=$G(SCVISIT) S:SCVISIT'="" SCVISIT=$$UP^XLFSTR(SCVISIT)
I SCVISIT'="" S SCVISIT=$S(SCVISIT="Y":"Y",SCVISIT="N":"N",SCVISIT="YES":"Y",SCVISIT="NO":"N",1:"")
;validate CLINIC
S CLINIC=$G(CLINIC)
;validate ORIGDT
S ORIGDT=$G(ORIGDT)
;single IEN
S ARIEN1=$G(ARIEN1)
I +ARIEN1 I '$D(^SDEC(409.85,+ARIEN1,0)) S ARIEN1=""
I +ARIEN1 D
.S ARIEN=+ARIEN1
.S FRULES=0 ;no rules - just return the single record
.D ONEPAT
I +ARIEN1 S @RET@(COUNT)=@RET@(COUNT)_$C(31) Q
;by patient
I +DFN D
.I 'SDTOP S ARIEN=0 F S ARIEN=$O(^SDEC(409.85,"B",+DFN,ARIEN)) Q:ARIEN'>0 D ONEPAT ;I MAXREC,COUNT'<MAXREC Q
.I +SDTOP S ARIEN=999999999 F S ARIEN=$O(^SDEC(409.85,"B",+DFN,ARIEN),-1) Q:ARIEN'>0 D ONEPAT
;clinic
I CLINIC'="" D G ARX
.S SDI=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:1)
.F SDI=SDI:1:$L(CLINIC,"|") S SDCL=$P(CLINIC,"|",SDI) D I MAXREC,COUNT'<MAXREC Q
..Q:SDCL=""
..I DESDT'="" D Q ;GCC DESDT desired dates by pipe
...S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:1)
...F SDT=SDT:1:$L(DESDT,"|") S DES=$P(DESDT,"|",SDT) D I MAXREC,COUNT'<MAXREC Q
....Q:DES=""
....S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
....F S ARIEN=$O(^SDEC(409.85,"GCC",SDCL,DES,ARIEN)) Q:ARIEN="" D I MAXREC,COUNT'<MAXREC S SDSUB=SDCL_"|"_SDT_"|"_ARIEN Q
.....D ONEPAT
..;
..S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,ORIGDT'="":ORIGDT-1,1:SDBEG-1) ;GC
..F S SDT=$O(^SDEC(409.85,"GC",SDCL,SDT)) Q:SDT="" Q:((ORIGDT'="")&(SDT>ORIGDT)) Q:(ORIGDT="")&(SDT>SDEND) D I MAXREC,COUNT'<MAXREC Q
...S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
...F S ARIEN=$O(^SDEC(409.85,"GC",SDCL,SDT,ARIEN)) Q:ARIEN="" D I MAXREC,COUNT'<MAXREC S SDSUB=SDI_"|"_SDT_"|"_ARIEN Q
....D ONEPAT
;by service
I SVCL'="" D G ARX
.N PR1,SDT,SVC
.S SDI=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1),1:1)
.F SDI=SDI:1:$L(SVCL,"|") S SVC=$P(SVCL,"|",SDI) D I MAXREC,COUNT'<MAXREC Q
..Q:SVC=""
..;I DESDTR'="" D ;desired date range range <begin> ~ <end> not implemented
..I DESDT'="" D Q ;GSC DESDT desired dates by pipe
...S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:1)
...F SDT=SDT:1:$L(DESDT,"|") S DES=$P(DESDT,"|",SDT) D I MAXREC,COUNT'<MAXREC Q
....Q:DES=""
....S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
....F S ARIEN=$O(^SDEC(409.85,"GSC",SVC,DES,ARIEN)) Q:ARIEN="" D I MAXREC,COUNT'<MAXREC S SDSUB=SVC_"|"_SDT_"|"_ARIEN Q
.....D ONEPAT
..I PRL'="" D Q ;GSP
...S SDK=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:1)
...F SDK=SDK:1:$L(PRL,"|") S PR1=$P(PRL,"|",SDK) D I MAXREC,COUNT'<MAXREC Q
....S SDT=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3)-1,1:SDBEG-1)
....F S SDT=$O(^SDEC(409.85,"GSP",SVC,PR1,SDT)) Q:SDT="" Q:SDT>SDEND D I MAXREC,COUNT'<MAXREC Q
.....S ARIEN=$S($P(LASTSUB,"|",4)'="":$P(LASTSUB,"|",4),1:0)
.....F S ARIEN=$O(^SDEC(409.85,"GSP",SVC,PR1,SDT,ARIEN)) Q:ARIEN="" D ONEPAT I MAXREC,COUNT'<MAXREC S SDSUB=SVC_"|"_SDK_"|"_SDT_"|"_ARIEN Q
..I SVCR'="" D Q ;GSB - WL service connected
...S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:SDBEG-1)
...F S SDT=$O(^SDEC(409.85,"GSB",SVC,$E(SVCR),SDT)) Q:SDT="" Q:SDT>SDEND D I MAXREC,COUNT'<MAXREC Q
....S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
....F S ARIEN=$O(^SDEC(409.85,"GSB",SVC,$E(SVCR),SDT,ARIEN)) Q:ARIEN="" D ONEPAT I MAXREC,COUNT'<MAXREC S SDSUB=SVC_"|"_SDT_"|"_ARIEN Q
..I SCVISIT'="" D Q ;GSA - Patient Service Connected
...S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:SDBEG-1)
...F S SDT=$O(^SDEC(409.85,"GSA",SVC,$E(SCVISIT),SDT)) Q:SDT="" Q:SDT>SDEND D I MAXREC,COUNT'<MAXREC Q
....S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
....F S ARIEN=$O(^SDEC(409.85,"GSA",SVC,$E(SCVISIT),SDT,ARIEN)) Q:ARIEN="" D ONEPAT I MAXREC,COUNT'<MAXREC S SDSUB=SVC_"|"_SDT_"|"_ARIEN Q
..S SDT=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2)-1,1:SDBEG-1) ;GS
..F S SDT=$O(^SDEC(409.85,"GS",SVC,SDT)) Q:SDT="" Q:SDT>SDEND D I MAXREC,COUNT'<MAXREC Q
...S ARIEN=$S($P(LASTSUB,"|",3)'="":$P(LASTSUB,"|",3),1:0)
...F S ARIEN=$O(^SDEC(409.85,"GS",SVC,SDT,ARIEN)) Q:ARIEN="" D I MAXREC,COUNT'<MAXREC S SDSUB=SDI_"|"_SDT_"|"_ARIEN Q
....D ONEPAT
;
;all by date range
I 'DFN D
.I 'SDTOP D
..S SDJ=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1)-1,1:SDBEG-1)
..F S SDJ=$O(^SDEC(409.85,"E","O",SDJ)) Q:SDJ'>0 Q:SDJ>SDEND D I MAXREC,COUNT'<MAXREC Q
...S ARIEN=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2),1:0)
...F S ARIEN=$O(^SDEC(409.85,"E","O",SDJ,ARIEN)) Q:ARIEN'>0 D I MAXREC,COUNT'<MAXREC S SDSUB=SDJ_"|"_ARIEN Q
....S SDSUB=""
....D ONEPAT
.I +SDTOP D
..S SDJ=$S($P(LASTSUB,"|",1)'="":$P(LASTSUB,"|",1)+1,1:SDEND+1)
..F S SDJ=$O(^SDEC(409.85,"E","O",SDJ),-1) Q:SDJ'>0 Q:SDJ<SDBEG D I MAXREC,COUNT'<MAXREC Q
...S ARIEN=$S($P(LASTSUB,"|",2)'="":$P(LASTSUB,"|",2),1:999999999)
...F S ARIEN=$O(^SDEC(409.85,"E","O",SDJ,ARIEN),-1) Q:ARIEN'>0 D I MAXREC,COUNT'<MAXREC S SDSUB=SDJ_"|"_ARIEN Q
....S SDSUB=""
....D ONEPAT
ARX S SDTMP=@RET@(COUNT) S SDTMP=$P(SDTMP,$C(30),1)
S:$G(SDSUB)'="" $P(SDTMP,U,56)=SDSUB
S @RET@(COUNT)=SDTMP_$C(30,31)
Q
HDR ;Send back the header
; 1 2
S SDRTMP="T00030DFN^T00030NAME"
; 3 4 5 6 7 8
S SDRTMP=SDRTMP_"^T00030HRN^T00030DOB^T00030SSN^T00030GENDER^I00010IEN^D00030ORIGDT"
; 9 10 11 12 13
S SDRTMP=SDRTMP_"^T00030INSTIEN^T00030INSTNAME^T00030TYPE^T00030CLINIEN^T00030CLINNAME"
; 14 15 16 17 18 19
S SDRTMP=SDRTMP_"^T00030USERIEN^T00030USERNAME^T00030PRIO^T00030REQBY^T00030PROVIEN^T00030PROVNAME"
; 20 21 22
S SDRTMP=SDRTMP_"^T00030DAPTDT^T00250COMM^T00030ENROLLMENT_PRIORITY"
; 23 24 25
S SDRTMP=SDRTMP_"^T00010MULTIPLE APPOINTMENT RTC^T00010MULT APPT RTC INTERVAL^T00010MULT APPT NUMBER"
; 26 27 28 29 30
S SDRTMP=SDRTMP_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"
; 31 32 33 34 35 36
S SDRTMP=SDRTMP_"^T00030TYPEIEN^T00030TYPENAME^T00100PCONTACT^T00030ARDISPD^T00030ARDISPU^T00030ARDISPUN"
; 37 38 39 40 41
S SDRTMP=SDRTMP_"^T00030WLSVCCON^T00030PADDRES1^T00030PADDRES2^T00030PADDRES3^T00030PCITY"
; 42 43 44 45 46 47
S SDRTMP=SDRTMP_"^T00030PSTATE^T00030PCOUNTRY^T00030PZIP4^T00050GAF^T00030DATE^T00030MTRCDATES"
; 48 49 50 51 52 53
S SDRTMP=SDRTMP_"^T00100SENSITIVE^T00030NU49^T00030NU50^T00030NU51^T00030NU52^T00030NU53"
; 54 55 56 57 58 59
S SDRTMP=SDRTMP_"^T00030NU54^T00030NU55^T00030LASTSUB^T00030STOPIEN^T00030STOPNAME^T00250APPT_SCHED_DATE"
S SDRTMP=SDRTMP_"^T00030MRTCCOUNT^T00030PTPHONE^T00030APPTYPE^T00030EESTAT^T00030PRHBLOC^T00030APPTPTRS"
S SDRTMP=SDRTMP_"^T00250CHILDREN^T00030SDPARENT"
;
; Removed unnamed column header. 694 wtc 7/16/2019
;
;S SDRTMP=SDRTMP_"^T00030HRN^T00030BADADD^T00030OPHONE^T00030NOK^T00030^T00030KNAME^T00030KREL^T00030KPHONE"
S SDRTMP=SDRTMP_"^T00030HRN^T00030BADADD^T00030OPHONE^T00030NOK^T00030KNAME^T00030KREL^T00030KPHONE"
;
; Removed unnamed column header. 694 wtc 7/16/2019
;
;S SDRTMP=SDRTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP^T00030"
S SDRTMP=SDRTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP"
S SDRTMP=SDRTMP_"^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"
S SDRTMP=SDRTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP"
S SDRTMP=SDRTMP_"^T00030PCOUNTY^T00030PETH^T00030PRACE^T00030PMARITAL^T00030PRELIGION^T00030PTACTIVE"
S SDRTMP=SDRTMP_"^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE^T00030PTZIP^T00030PTZIP+4"
S SDRTMP=SDRTMP_"^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTMPPHONE^T00030PTSTART^T00030PTEND^T00030PCELL^T00030PPAGER^T00030PEMAIL"
S SDRTMP=SDRTMP_"^T00030PF_FFF^T00030PF_VCD^T00030PFNATIONAL^T00030PFLOCAL^T00030SUBGRP^T00030CAT8G^T01000SIMILAR"
S SDRTMP=SDRTMP_"^T00032VAOS_GUID^T00030CPHONE^T00030CLET" ; wtc patch 686 3/23/18 added for VAOS requests ;CT added call phone & letter
S SDRTMP=SDRTMP_"^T00030CEMAIL^T00030CTEXT^T00030CSEC" ; 813 contact email,text,sec msg
S @RET@(COUNT)=SDRTMP_$C(30)
Q
;
ONEPAT ; Process one patient
N APPTYPE,ARMRTC,CHILDREN,SDI,PRHBLOC
K ARASD,ARDATA,ARSDOA,ARDAM,ARCLERK,ARCLERKN,SDAPPT
S FRULES=$G(FRULES)
D GETS^DIQ(FNUM,ARIEN,"**","IE","ARDATA","ARMSG")
Q:'$D(ARDATA)
S ARSTAT=ARDATA(FNUM,ARIEN_",",23,"I")
I FRULES I '+$G(CLOSED) Q:ARSTAT="C" ; Ignore CLOSED records; CLOSED setup and used from SDEC54 only
S ARORIGDT=ARDATA(FNUM,ARIEN_",",1,"I")
I FRULES I ($P(ARORIGDT,".",1)<SDBEG)!($P(ARORIGDT,".",1)>SDEND) Q
S DFN=ARDATA(FNUM,ARIEN_",",.01,"I")
Q:DFN=""
S SDPS=ARDATA(FNUM,ARIEN_",",.02,"E")
S SDCL=ARDATA(FNUM,ARIEN_",",8,"I")
Q:(SDCL'="")&($$GET1^DIQ(44,SDCL_",",50.01,"I")=1) ;check OOS? in file 44
S PRHBLOC=$S($$GET1^DIQ(44,SDCL_",",2500,"I")="Y":1,1:0)
;collect demographics
D PDEMO^SDECU3(.SDDEMO,DFN) ;alb/sat 658 PDEMO moved to SDECU3
S NAME=SDDEMO("NAME")
S DOB=SDDEMO("DOB")
S GENDER=SDDEMO("GENDER")
S HRN=SDDEMO("HRN")
S SSN=SDDEMO("SSN")
S INSTIEN=SDDEMO("INSTIEN")
S INSTNAME=SDDEMO("INSTNAME")
S PRIGRP=SDDEMO("PRIGRP")
S ELIGIEN=SDDEMO("ELIGIEN")
S ELIGNAME=SDDEMO("ELIGNAME")
S SVCCONN=SDDEMO("SVCCONN")
S SVCCONNP=SDDEMO("SVCCONNP")
S TYPEIEN=SDDEMO("TYPEIEN")
S TYPENAME=SDDEMO("TYPENAME")
S PADDRES1=SDDEMO("PADDRES1")
S PADDRES2=SDDEMO("PADDRES2")
S PADDRES3=SDDEMO("PADDRES3")
S PCITY=SDDEMO("PCITY")
S PSTATE=SDDEMO("PSTATE")
S PCOUNTRY=SDDEMO("PCOUNTRY")
S PZIP4=SDDEMO("PZIP+4")
;
S GAF=$$GAF^SDECU2(DFN)
;
S PTPHONE=SDDEMO("HPHONE") ;ARDATA(FNUM,ARIEN_",",.05,"I") ;msc/sat
S ARINST=ARDATA(FNUM,ARIEN_",",2,"I")
S ARINSTNM=ARDATA(FNUM,ARIEN_",",2,"E")
S ARTYPE=ARDATA(FNUM,ARIEN_",",4,"I")
;
; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
;
I ARTYPE="VETERAN",'$G(VAOSUSR(0)) Q ;
;
S VAOSGUID=ARDATA(FNUM,ARIEN_",",5,"I") ; wtc patch 686 3/23/18 added for VAOS requests
S ARCLIENL=ARDATA(FNUM,ARIEN_",",8,"I")
S ARSTOP=ARDATA(FNUM,ARIEN_",",8.5,"I")
S ARSTOPN=ARDATA(FNUM,ARIEN_",",8.5,"E")
;S ARCLIEN=$P($G(^SDWL(409.32,+ARCLIENL,0)),U,1)
S ARCLIEN=ARCLIENL
S ARCLNAME=ARDATA(FNUM,ARIEN_",",8,"E")
S APPTYPE=ARDATA(FNUM,ARIEN_",",8.7,"I")
S ARUSER=ARDATA(FNUM,ARIEN_",",9,"I")
S ARUSRNM=ARDATA(FNUM,ARIEN_",",9,"E")
S AREDT=$G(ARDATA(FNUM,ARIEN_",",9.5,"E")) ;53
S ARPRIO=ARDATA(FNUM,ARIEN_",",10,"I")
S ARENPRI=ARDATA(FNUM,ARIEN_",",10.5,"E") ;msc/sat
S ARREQBY=ARDATA(FNUM,ARIEN_",",11,"I")
S ARPROV=ARDATA(FNUM,ARIEN_",",12,"I")
S ARPROVNM=ARDATA(FNUM,ARIEN_",",12,"E")
;S ARSDOA=ARDATA(FNUM,ARIEN_",",13,"E") ;scheduled date of appt
S ARSDOA=ARDATA(FNUM,ARIEN_",",13,"I") ;scheduled date of appt
; Change date/time conversion so midnight is handled properly. wtc/pwc 694 1/7/2020
;
S ARSDOA=$$FMTONET^SDECDATE(ARSDOA,"N") ;
S ARDAM=ARDATA(FNUM,ARIEN_",",13.1,"E") ;date appt. made
S ARCLERK=ARDATA(FNUM,ARIEN_",",13.7,"I") ;appt clerk ien
S ARCLERKN=ARDATA(FNUM,ARIEN_",",13.7,"E") ;appt clerk name
S ARASD=""
S:ARSDOA'="" $P(ARASD,"~~",1)=ARSDOA
S:ARCLERK'="" $P(ARASD,"~~",12)=ARCLERK
S:ARCLERKN'="" $P(ARASD,"~~",13)=ARCLERKN
S:ARDAM'="" $P(ARASD,"~~",17)=ARDAM
S ARSVCCON=ARDATA(FNUM,ARIEN_",",15,"E")
S ARDAPTDT=ARDATA(FNUM,ARIEN_",",22,"I")
S ARCOMM=ARDATA(FNUM,ARIEN_",",25,"I")
;S AREESTAT=ARDATA(FNUM,ARIEN_",",27,"I")
S ARMAR=$$GET1^DIQ(409.85,ARIEN_",",41)
S ARMAI=$$GET1^DIQ(409.85,ARIEN_",",42)
S ARMAN=$$GET1^DIQ(409.85,ARIEN_",",43)
S ARPC=$$WLPC^SDECAR1A(.ARDATA,ARIEN)
S ARDISPD=ARDATA(FNUM,ARIEN_",",19,"E")
S ARDISPU=ARDATA(FNUM,ARIEN_",",20,"I")
S ARDISPUN=ARDATA(FNUM,ARIEN_",",20,"E")
S APPTPTRS=$$GETAPPTS^SDECAR1A(ARIEN)
S CHILDREN=$$CHILDREN^SDECAR1A(ARIEN)
S ARMRTC=$$MRTC^SDECAR(ARIEN)
S SDPARENT=ARDATA(FNUM,ARIEN_",",43.8,"I")
S SDSENS=$$PTSEC^SDECUTL(DFN)
S (SDI,SDMTRC)="" F S SDI=$O(ARDATA(409.857,SDI)) Q:SDI="" S SDMTRC=$S(SDMTRC'="":SDMTRC_"|",1:"")_ARDATA(409.857,SDI,.01,"E")
S COUNT=COUNT+1
; 1 2 3 4 5 6 7 8 9 10 11
S STR=DFN_U_""_U_""_U_""_U_""_U_""_U_ARIEN_U_ARORIGDT_U_ARINST_U_ARINSTNM_U_ARTYPE
; 12 13 14 15 16 17 18
S STR=STR_U_ARCLIEN_U_ARCLNAME_U_ARUSER_U_ARUSRNM_U_ARPRIO_U_ARREQBY_U_ARPROV
; 19 20 21 22 23 24 25
S STR=STR_U_ARPROVNM_U_ARDAPTDT_U_ARCOMM_U_ARENPRI_U_ARMAR_U_ARMAI_U_ARMAN
; 26 27 28;29 30 31 32 33
S STR=STR_U_PRIGRP_U_ELIGIEN_U_ELIGNAME_U_SVCCONN_U_SVCCONNP_U_TYPEIEN_U_TYPENAME_U_ARPC
; 34 35 36 37 38 39 40 41 42
S STR=STR_U_ARDISPD_U_ARDISPU_U_ARDISPUN_U_ARSVCCON_U_""_U_""_U_""_U_""_U_""
; 43 44 45 46 47 48 57 (save 56 for SDSUB)
S STR=STR_U_""_U_""_U_GAF_U_AREDT_U_SDMTRC_U_SDSENS_U_U_U_U_U_U_U_U_U_ARSTOP_U_ARSTOPN_U_ARASD
S STR=STR_U_ARMRTC_U_PTPHONE_U_APPTYPE_U_SDPS_U_PRHBLOC_U_APPTPTRS_U_CHILDREN_U_SDPARENT
D ARDEMO^SDECAR1A(.STR,DFN) ;alb/sat 658 - get demographics
S $P(STR,"^",119)=VAOSGUID ; wtc patch 686 3/23/18 added for VAOS requests. Revised to store in piece 119.
S SDAPPT=$$CALLET^SDECAR1A(DFN,ARIEN) ;CT *745 # OF CALLS MADE AND DATE LAST LETTER SENT
S $P(STR,"^",120)=$P(SDAPPT,"^",1),$P(STR,"^",121)=$P(SDAPPT,"^",2) ;SDCALL ^ SDCLET *745
S $P(STR,"^",122)=$P(SDAPPT,"^",3) ;813
S $P(STR,"^",123)=$P(SDAPPT,"^",4) ;813
S $P(STR,"^",124)=$P(SDAPPT,"^",5) ;813
S @RET@(COUNT)=STR_$C(30)
Q
;
ARGUID(RET,GUID) ;
;
; Return SDEC Appointment Request data for a VAOS Request GUID.
;
; wtc SD*5.3*686 4/19/2018
;
N FNUM,ARIEN,SDTMP,COUNT ;
S RET="^TMP(""SDEC"","_$J_")" ;
K @RET ;
S FNUM=$$FNUM^SDECAR,COUNT=0 ;
S ARIEN=$O(^SDEC(409.85,"GUID",GUID,0)) ;
D HDR ;
I ARIEN>0 D ;
. ;
. ; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
. ;
. N VAOSUSR ;
. D OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST") ;
. ;
. D ONEPAT ;
G ARX ;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECAR1 17752 printed Oct 16, 2024@18:52:17 Page 2
SDECAR1 ;ALB/SAT,WTC,CT,LAB - VISTA SCHEDULING RPCS ;MAR 23, 2022@10:55
+1 ;;5.3;Scheduling;**627,642,658,686,694,745,813**;Aug 13, 1993;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
+6 ; Get SDEC APPOINTMENT REQUEST for all entries in the user's Institution
+7 ; where the Current Status is not C(losed).
ARGET(RET,ARIEN1,MAXREC,SDBEG,SDEND,DFN,LASTSUB,SDTOP,SVCL,DESDT,PRL,SVCR,SCVISIT,CLINIC,ORIGDT) ;Appt Req GET ;alb/sat 658 add SVCL-SCVISIT
ARGET1 ;
+1 ;29 SVCCONN - SERVICE CONNECTED? field .301 of the PATIENT file
+2 ;37 ARSVCCON - SERVICE CONNECTED PRIORITY field 15 of the SDEC APPT REQUEST file
+3 ;
+4 NEW CLOSED,FNUM,NAME,DOB,SSN4,GENDER,ARORIGDT,ARINST,ARINSTNM,ARTYPE,ARTEAM,ARPOS
+5 NEW ELIGIEN,ELIGNAME,FRULES,GLOREF,HRN,INSTIEN,INSTNAME,PRIGRP,SVCCONN,SVCCONNP,TYPEIEN,TYPENAME
+6 NEW PCOUNTRY,SDSUB,SDTMP,SSN,ARSSIEN,ARSSNAME,ARCLIEN,ARCLNAME
+7 NEW ARUSER,ARPRIO,ARREQBY,ARPROV,ARPROVNM,ARDAPTDT,ARCOMM,AREESTAT,ARUSRNM
+8 NEW ARCLIENL,AREDT,ARIEN,PTINFOLSTA,ARDISPD,ARDISPU,ARDISPUN,ARSVCCON
+9 NEW ARMAI,ARMAN,ARMAR,ARSTAT,ARSTOP,ARSTOPN,COUNT,DES,SDK,STR,SDRTMP
+10 NEW PCITY,GAF,PSTATE,PZIP4,PADDRES1,PADDRES2,PADDRES3,PPC,PTPHONE,ARENPRI,ARASD,ARPC,ARDATA
+11 NEW SDCL,SDI,SDJ,SDMTRC,SDPARENT,SDPS,SDSENS,SDDEMO,X,Y,%DT,APPTPTRS
+12 ; wtc patch 686 3/23/18 added for VAOS requests
NEW VAOSGUID
+13 ;
+14 ; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
+15 ;
+16 ;
NEW VAOSUSR
+17 ;
DO OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST")
+18 ;
+19 SET RET="^TMP(""SDEC"","_$JOB_")"
+20 KILL @RET
+21 SET FNUM=$$FNUM^SDECAR
SET COUNT=0
+22 SET MAXREC=+$GET(MAXREC,50)
+23 DO HDR
+24 SET GLOREF=$NAME(^SDEC(409.85,"C",DUZ(2)))
+25 SET FRULES=1
+26 SET ARIEN=0
+27 ;F S WLIEN=$O(@GLOREF@(WLIEN)) Q:'WLIEN D ONEPAT I MAXREC,COUNT'<MAXREC Q
+28 SET SDBEG=$GET(SDBEG)
+29 IF SDBEG'=""
SET %DT=""
SET X=$PIECE(SDBEG,"@",1)
DO ^%DT
SET SDBEG=Y
IF Y=-1
SET SDBEG=3100101
+30 IF SDBEG=""
SET SDBEG=3100101
+31 SET SDEND=$GET(SDEND)
+32 IF SDEND'=""
SET %DT=""
SET X=$PIECE(SDEND,"@",1)
DO ^%DT
SET SDEND=Y
IF Y=-1
SET SDEND=$$FMADD^XLFDT($EXTRACT($$NOW^XLFDT,1,12),-90)
+33 IF SDEND=""
SET SDEND=$$FMADD^XLFDT($EXTRACT($$NOW^XLFDT,1,12),-90)
+34 SET DFN=$GET(DFN)
+35 IF DFN'=""
IF '$DATA(^DPT(DFN,0))
SET DFN=""
+36 SET LASTSUB=$SELECT(DFN="":$GET(LASTSUB),1:"")
+37 SET SDTOP=+$GET(SDTOP)
+38 ;validate SVCL
+39 SET SVCL=$GET(SVCL)
+40 IF SVCL'=""
Begin DoDot:1
+41 FOR SDI=$LENGTH(SVCL,"|"):-1:1
SET SVC=$PIECE(SVCL,"|",SDI)
Begin DoDot:2
+42 IF (SVC="")!('$DATA(^DIC(40.7,+SVC,0)))
SET SVCL=$$PD^SDECUTL(SVCL,SDI,"|")
End DoDot:2
End DoDot:1
+43 ;validate DESDT
+44 SET DESDT=$GET(DESDT)
+45 ;validate PRL
+46 SET PRL=$GET(PRL)
+47 IF PRL'=""
Begin DoDot:1
+48 NEW PR
+49 FOR SDI=$LENGTH(PRL,"|"):-1:1
SET PR=$PIECE(PRL,"|",SDI)
Begin DoDot:2
+50 IF "012345678"'[PR
SET PR=$EXTRACT(PR,7)
+51 IF "012345678"'[PR
SET PRL=$$PD^SDECUTL(PRL,SDI,"|")
End DoDot:2
End DoDot:1
+52 ;validate SVCR
+53 SET SVCR=$GET(SVCR)
if SVCR'=""
SET SVCR=$$UP^XLFSTR(SVCR)
+54 IF SVCR'=""
SET SVCR=$SELECT(SVCR="Y":1,SVCR="N":0,SVCR="YES":1,SVCR="NO":0,1:"")
+55 ;validate SCVISIT
+56 SET SCVISIT=$GET(SCVISIT)
if SCVISIT'=""
SET SCVISIT=$$UP^XLFSTR(SCVISIT)
+57 IF SCVISIT'=""
SET SCVISIT=$SELECT(SCVISIT="Y":"Y",SCVISIT="N":"N",SCVISIT="YES":"Y",SCVISIT="NO":"N",1:"")
+58 ;validate CLINIC
+59 SET CLINIC=$GET(CLINIC)
+60 ;validate ORIGDT
+61 SET ORIGDT=$GET(ORIGDT)
+62 ;single IEN
+63 SET ARIEN1=$GET(ARIEN1)
+64 IF +ARIEN1
IF '$DATA(^SDEC(409.85,+ARIEN1,0))
SET ARIEN1=""
+65 IF +ARIEN1
Begin DoDot:1
+66 SET ARIEN=+ARIEN1
+67 ;no rules - just return the single record
SET FRULES=0
+68 DO ONEPAT
End DoDot:1
+69 IF +ARIEN1
SET @RET@(COUNT)=@RET@(COUNT)_$CHAR(31)
QUIT
+70 ;by patient
+71 IF +DFN
Begin DoDot:1
+72 ;I MAXREC,COUNT'<MAXREC Q
IF 'SDTOP
SET ARIEN=0
FOR
SET ARIEN=$ORDER(^SDEC(409.85,"B",+DFN,ARIEN))
if ARIEN'>0
QUIT
DO ONEPAT
+73 IF +SDTOP
SET ARIEN=999999999
FOR
SET ARIEN=$ORDER(^SDEC(409.85,"B",+DFN,ARIEN),-1)
if ARIEN'>0
QUIT
DO ONEPAT
End DoDot:1
+74 ;clinic
+75 IF CLINIC'=""
Begin DoDot:1
+76 SET SDI=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:1)
+77 FOR SDI=SDI:1:$LENGTH(CLINIC,"|")
SET SDCL=$PIECE(CLINIC,"|",SDI)
Begin DoDot:2
+78 if SDCL=""
QUIT
+79 ;GCC DESDT desired dates by pipe
IF DESDT'=""
Begin DoDot:3
+80 SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:1)
+81 FOR SDT=SDT:1:$LENGTH(DESDT,"|")
SET DES=$PIECE(DESDT,"|",SDT)
Begin DoDot:4
+82 if DES=""
QUIT
+83 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+84 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GCC",SDCL,DES,ARIEN))
if ARIEN=""
QUIT
Begin DoDot:5
+85 DO ONEPAT
End DoDot:5
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SDCL_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:3
QUIT
+86 ;
+87 ;GC
SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,ORIGDT'="":ORIGDT-1,1:SDBEG-1)
+88 FOR
SET SDT=$ORDER(^SDEC(409.85,"GC",SDCL,SDT))
if SDT=""
QUIT
if ((ORIGDT'="")&(SDT>ORIGDT))
QUIT
if (ORIGDT="")&(SDT>SDEND)
QUIT
Begin DoDot:3
+89 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+90 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GC",SDCL,SDT,ARIEN))
if ARIEN=""
QUIT
Begin DoDot:4
+91 DO ONEPAT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SDI_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:3
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:2
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:1
GOTO ARX
+92 ;by service
+93 IF SVCL'=""
Begin DoDot:1
+94 NEW PR1,SDT,SVC
+95 SET SDI=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1),1:1)
+96 FOR SDI=SDI:1:$LENGTH(SVCL,"|")
SET SVC=$PIECE(SVCL,"|",SDI)
Begin DoDot:2
+97 if SVC=""
QUIT
+98 ;I DESDTR'="" D ;desired date range range <begin> ~ <end> not implemented
+99 ;GSC DESDT desired dates by pipe
IF DESDT'=""
Begin DoDot:3
+100 SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:1)
+101 FOR SDT=SDT:1:$LENGTH(DESDT,"|")
SET DES=$PIECE(DESDT,"|",SDT)
Begin DoDot:4
+102 if DES=""
QUIT
+103 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+104 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GSC",SVC,DES,ARIEN))
if ARIEN=""
QUIT
Begin DoDot:5
+105 DO ONEPAT
End DoDot:5
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SVC_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:3
QUIT
+106 ;GSP
IF PRL'=""
Begin DoDot:3
+107 SET SDK=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:1)
+108 FOR SDK=SDK:1:$LENGTH(PRL,"|")
SET PR1=$PIECE(PRL,"|",SDK)
Begin DoDot:4
+109 SET SDT=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3)-1,1:SDBEG-1)
+110 FOR
SET SDT=$ORDER(^SDEC(409.85,"GSP",SVC,PR1,SDT))
if SDT=""
QUIT
if SDT>SDEND
QUIT
Begin DoDot:5
+111 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",4)'="":$PIECE(LASTSUB,"|",4),1:0)
+112 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GSP",SVC,PR1,SDT,ARIEN))
if ARIEN=""
QUIT
DO ONEPAT
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SVC_"|"_SDK_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:5
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:3
QUIT
+113 ;GSB - WL service connected
IF SVCR'=""
Begin DoDot:3
+114 SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:SDBEG-1)
+115 FOR
SET SDT=$ORDER(^SDEC(409.85,"GSB",SVC,$EXTRACT(SVCR),SDT))
if SDT=""
QUIT
if SDT>SDEND
QUIT
Begin DoDot:4
+116 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+117 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GSB",SVC,$EXTRACT(SVCR),SDT,ARIEN))
if ARIEN=""
QUIT
DO ONEPAT
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SVC_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:3
QUIT
+118 ;GSA - Patient Service Connected
IF SCVISIT'=""
Begin DoDot:3
+119 SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:SDBEG-1)
+120 FOR
SET SDT=$ORDER(^SDEC(409.85,"GSA",SVC,$EXTRACT(SCVISIT),SDT))
if SDT=""
QUIT
if SDT>SDEND
QUIT
Begin DoDot:4
+121 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+122 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GSA",SVC,$EXTRACT(SCVISIT),SDT,ARIEN))
if ARIEN=""
QUIT
DO ONEPAT
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SVC_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:3
QUIT
+123 ;GS
SET SDT=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2)-1,1:SDBEG-1)
+124 FOR
SET SDT=$ORDER(^SDEC(409.85,"GS",SVC,SDT))
if SDT=""
QUIT
if SDT>SDEND
QUIT
Begin DoDot:3
+125 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",3)'="":$PIECE(LASTSUB,"|",3),1:0)
+126 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"GS",SVC,SDT,ARIEN))
if ARIEN=""
QUIT
Begin DoDot:4
+127 DO ONEPAT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SDI_"|"_SDT_"|"_ARIEN
QUIT
End DoDot:3
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:2
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:1
GOTO ARX
+128 ;
+129 ;all by date range
+130 IF 'DFN
Begin DoDot:1
+131 IF 'SDTOP
Begin DoDot:2
+132 SET SDJ=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1)-1,1:SDBEG-1)
+133 FOR
SET SDJ=$ORDER(^SDEC(409.85,"E","O",SDJ))
if SDJ'>0
QUIT
if SDJ>SDEND
QUIT
Begin DoDot:3
+134 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2),1:0)
+135 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"E","O",SDJ,ARIEN))
if ARIEN'>0
QUIT
Begin DoDot:4
+136 SET SDSUB=""
+137 DO ONEPAT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SDJ_"|"_ARIEN
QUIT
End DoDot:3
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:2
+138 IF +SDTOP
Begin DoDot:2
+139 SET SDJ=$SELECT($PIECE(LASTSUB,"|",1)'="":$PIECE(LASTSUB,"|",1)+1,1:SDEND+1)
+140 FOR
SET SDJ=$ORDER(^SDEC(409.85,"E","O",SDJ),-1)
if SDJ'>0
QUIT
if SDJ<SDBEG
QUIT
Begin DoDot:3
+141 SET ARIEN=$SELECT($PIECE(LASTSUB,"|",2)'="":$PIECE(LASTSUB,"|",2),1:999999999)
+142 FOR
SET ARIEN=$ORDER(^SDEC(409.85,"E","O",SDJ,ARIEN),-1)
if ARIEN'>0
QUIT
Begin DoDot:4
+143 SET SDSUB=""
+144 DO ONEPAT
End DoDot:4
IF MAXREC
IF COUNT'<MAXREC
SET SDSUB=SDJ_"|"_ARIEN
QUIT
End DoDot:3
IF MAXREC
IF COUNT'<MAXREC
QUIT
End DoDot:2
End DoDot:1
ARX SET SDTMP=@RET@(COUNT)
SET SDTMP=$PIECE(SDTMP,$CHAR(30),1)
+1 if $GET(SDSUB)'=""
SET $PIECE(SDTMP,U,56)=SDSUB
+2 SET @RET@(COUNT)=SDTMP_$CHAR(30,31)
+3 QUIT
HDR ;Send back the header
+1 ; 1 2
+2 SET SDRTMP="T00030DFN^T00030NAME"
+3 ; 3 4 5 6 7 8
+4 SET SDRTMP=SDRTMP_"^T00030HRN^T00030DOB^T00030SSN^T00030GENDER^I00010IEN^D00030ORIGDT"
+5 ; 9 10 11 12 13
+6 SET SDRTMP=SDRTMP_"^T00030INSTIEN^T00030INSTNAME^T00030TYPE^T00030CLINIEN^T00030CLINNAME"
+7 ; 14 15 16 17 18 19
+8 SET SDRTMP=SDRTMP_"^T00030USERIEN^T00030USERNAME^T00030PRIO^T00030REQBY^T00030PROVIEN^T00030PROVNAME"
+9 ; 20 21 22
+10 SET SDRTMP=SDRTMP_"^T00030DAPTDT^T00250COMM^T00030ENROLLMENT_PRIORITY"
+11 ; 23 24 25
+12 SET SDRTMP=SDRTMP_"^T00010MULTIPLE APPOINTMENT RTC^T00010MULT APPT RTC INTERVAL^T00010MULT APPT NUMBER"
+13 ; 26 27 28 29 30
+14 SET SDRTMP=SDRTMP_"^T00030PRIGRP^T00030ELIGIEN^T00030ELIGNAME^T00030SVCCONN^T00030SVCCONNP"
+15 ; 31 32 33 34 35 36
+16 SET SDRTMP=SDRTMP_"^T00030TYPEIEN^T00030TYPENAME^T00100PCONTACT^T00030ARDISPD^T00030ARDISPU^T00030ARDISPUN"
+17 ; 37 38 39 40 41
+18 SET SDRTMP=SDRTMP_"^T00030WLSVCCON^T00030PADDRES1^T00030PADDRES2^T00030PADDRES3^T00030PCITY"
+19 ; 42 43 44 45 46 47
+20 SET SDRTMP=SDRTMP_"^T00030PSTATE^T00030PCOUNTRY^T00030PZIP4^T00050GAF^T00030DATE^T00030MTRCDATES"
+21 ; 48 49 50 51 52 53
+22 SET SDRTMP=SDRTMP_"^T00100SENSITIVE^T00030NU49^T00030NU50^T00030NU51^T00030NU52^T00030NU53"
+23 ; 54 55 56 57 58 59
+24 SET SDRTMP=SDRTMP_"^T00030NU54^T00030NU55^T00030LASTSUB^T00030STOPIEN^T00030STOPNAME^T00250APPT_SCHED_DATE"
+25 SET SDRTMP=SDRTMP_"^T00030MRTCCOUNT^T00030PTPHONE^T00030APPTYPE^T00030EESTAT^T00030PRHBLOC^T00030APPTPTRS"
+26 SET SDRTMP=SDRTMP_"^T00250CHILDREN^T00030SDPARENT"
+27 ;
+28 ; Removed unnamed column header. 694 wtc 7/16/2019
+29 ;
+30 ;S SDRTMP=SDRTMP_"^T00030HRN^T00030BADADD^T00030OPHONE^T00030NOK^T00030^T00030KNAME^T00030KREL^T00030KPHONE"
+31 SET SDRTMP=SDRTMP_"^T00030HRN^T00030BADADD^T00030OPHONE^T00030NOK^T00030KNAME^T00030KREL^T00030KPHONE"
+32 ;
+33 ; Removed unnamed column header. 694 wtc 7/16/2019
+34 ;
+35 ;S SDRTMP=SDRTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP^T00030"
+36 SET SDRTMP=SDRTMP_"^T00030KSTREET^T00030KSTREET2^T00030KSTREET3^T00030KCITY^T00030KSTATE^T00030KZIP"
+37 SET SDRTMP=SDRTMP_"^T00030NOK2^T00030K2NAME^T00030K2REL^T00030K2PHONE"
+38 SET SDRTMP=SDRTMP_"^T00030K2STREET^T00030K2STREET2^T00030K2STREET3^T00030K2CITY^T00030K2STATE^T00030K2ZIP"
+39 SET SDRTMP=SDRTMP_"^T00030PCOUNTY^T00030PETH^T00030PRACE^T00030PMARITAL^T00030PRELIGION^T00030PTACTIVE"
+40 SET SDRTMP=SDRTMP_"^T00030PTADDRESS1^T00030PTADDRESS2^T00030PTADDRESS3^T00030PTCITY^T00030PTSTATE^T00030PTZIP^T00030PTZIP+4"
+41 SET SDRTMP=SDRTMP_"^T00030PTCOUNTRY^T00030PTCOUNTY^T00030PTMPPHONE^T00030PTSTART^T00030PTEND^T00030PCELL^T00030PPAGER^T00030PEMAIL"
+42 SET SDRTMP=SDRTMP_"^T00030PF_FFF^T00030PF_VCD^T00030PFNATIONAL^T00030PFLOCAL^T00030SUBGRP^T00030CAT8G^T01000SIMILAR"
+43 ; wtc patch 686 3/23/18 added for VAOS requests ;CT added call phone & letter
SET SDRTMP=SDRTMP_"^T00032VAOS_GUID^T00030CPHONE^T00030CLET"
+44 ; 813 contact email,text,sec msg
SET SDRTMP=SDRTMP_"^T00030CEMAIL^T00030CTEXT^T00030CSEC"
+45 SET @RET@(COUNT)=SDRTMP_$CHAR(30)
+46 QUIT
+47 ;
ONEPAT ; Process one patient
+1 NEW APPTYPE,ARMRTC,CHILDREN,SDI,PRHBLOC
+2 KILL ARASD,ARDATA,ARSDOA,ARDAM,ARCLERK,ARCLERKN,SDAPPT
+3 SET FRULES=$GET(FRULES)
+4 DO GETS^DIQ(FNUM,ARIEN,"**","IE","ARDATA","ARMSG")
+5 if '$DATA(ARDATA)
QUIT
+6 SET ARSTAT=ARDATA(FNUM,ARIEN_",",23,"I")
+7 ; Ignore CLOSED records; CLOSED setup and used from SDEC54 only
IF FRULES
IF '+$GET(CLOSED)
if ARSTAT="C"
QUIT
+8 SET ARORIGDT=ARDATA(FNUM,ARIEN_",",1,"I")
+9 IF FRULES
IF ($PIECE(ARORIGDT,".",1)<SDBEG)!($PIECE(ARORIGDT,".",1)>SDEND)
QUIT
+10 SET DFN=ARDATA(FNUM,ARIEN_",",.01,"I")
+11 if DFN=""
QUIT
+12 SET SDPS=ARDATA(FNUM,ARIEN_",",.02,"E")
+13 SET SDCL=ARDATA(FNUM,ARIEN_",",8,"I")
+14 ;check OOS? in file 44
if (SDCL'="")&($$GET1^DIQ(44,SDCL_",",50.01,"I")=1)
QUIT
+15 SET PRHBLOC=$SELECT($$GET1^DIQ(44,SDCL_",",2500,"I")="Y":1,1:0)
+16 ;collect demographics
+17 ;alb/sat 658 PDEMO moved to SDECU3
DO PDEMO^SDECU3(.SDDEMO,DFN)
+18 SET NAME=SDDEMO("NAME")
+19 SET DOB=SDDEMO("DOB")
+20 SET GENDER=SDDEMO("GENDER")
+21 SET HRN=SDDEMO("HRN")
+22 SET SSN=SDDEMO("SSN")
+23 SET INSTIEN=SDDEMO("INSTIEN")
+24 SET INSTNAME=SDDEMO("INSTNAME")
+25 SET PRIGRP=SDDEMO("PRIGRP")
+26 SET ELIGIEN=SDDEMO("ELIGIEN")
+27 SET ELIGNAME=SDDEMO("ELIGNAME")
+28 SET SVCCONN=SDDEMO("SVCCONN")
+29 SET SVCCONNP=SDDEMO("SVCCONNP")
+30 SET TYPEIEN=SDDEMO("TYPEIEN")
+31 SET TYPENAME=SDDEMO("TYPENAME")
+32 SET PADDRES1=SDDEMO("PADDRES1")
+33 SET PADDRES2=SDDEMO("PADDRES2")
+34 SET PADDRES3=SDDEMO("PADDRES3")
+35 SET PCITY=SDDEMO("PCITY")
+36 SET PSTATE=SDDEMO("PSTATE")
+37 SET PCOUNTRY=SDDEMO("PCOUNTRY")
+38 SET PZIP4=SDDEMO("PZIP+4")
+39 ;
+40 SET GAF=$$GAF^SDECU2(DFN)
+41 ;
+42 ;ARDATA(FNUM,ARIEN_",",.05,"I") ;msc/sat
SET PTPHONE=SDDEMO("HPHONE")
+43 SET ARINST=ARDATA(FNUM,ARIEN_",",2,"I")
+44 SET ARINSTNM=ARDATA(FNUM,ARIEN_",",2,"E")
+45 SET ARTYPE=ARDATA(FNUM,ARIEN_",",4,"I")
+46 ;
+47 ; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
+48 ;
+49 ;
IF ARTYPE="VETERAN"
IF '$GET(VAOSUSR(0))
QUIT
+50 ;
+51 ; wtc patch 686 3/23/18 added for VAOS requests
SET VAOSGUID=ARDATA(FNUM,ARIEN_",",5,"I")
+52 SET ARCLIENL=ARDATA(FNUM,ARIEN_",",8,"I")
+53 SET ARSTOP=ARDATA(FNUM,ARIEN_",",8.5,"I")
+54 SET ARSTOPN=ARDATA(FNUM,ARIEN_",",8.5,"E")
+55 ;S ARCLIEN=$P($G(^SDWL(409.32,+ARCLIENL,0)),U,1)
+56 SET ARCLIEN=ARCLIENL
+57 SET ARCLNAME=ARDATA(FNUM,ARIEN_",",8,"E")
+58 SET APPTYPE=ARDATA(FNUM,ARIEN_",",8.7,"I")
+59 SET ARUSER=ARDATA(FNUM,ARIEN_",",9,"I")
+60 SET ARUSRNM=ARDATA(FNUM,ARIEN_",",9,"E")
+61 ;53
SET AREDT=$GET(ARDATA(FNUM,ARIEN_",",9.5,"E"))
+62 SET ARPRIO=ARDATA(FNUM,ARIEN_",",10,"I")
+63 ;msc/sat
SET ARENPRI=ARDATA(FNUM,ARIEN_",",10.5,"E")
+64 SET ARREQBY=ARDATA(FNUM,ARIEN_",",11,"I")
+65 SET ARPROV=ARDATA(FNUM,ARIEN_",",12,"I")
+66 SET ARPROVNM=ARDATA(FNUM,ARIEN_",",12,"E")
+67 ;S ARSDOA=ARDATA(FNUM,ARIEN_",",13,"E") ;scheduled date of appt
+68 ;scheduled date of appt
SET ARSDOA=ARDATA(FNUM,ARIEN_",",13,"I")
+69 ; Change date/time conversion so midnight is handled properly. wtc/pwc 694 1/7/2020
+70 ;
+71 ;
SET ARSDOA=$$FMTONET^SDECDATE(ARSDOA,"N")
+72 ;date appt. made
SET ARDAM=ARDATA(FNUM,ARIEN_",",13.1,"E")
+73 ;appt clerk ien
SET ARCLERK=ARDATA(FNUM,ARIEN_",",13.7,"I")
+74 ;appt clerk name
SET ARCLERKN=ARDATA(FNUM,ARIEN_",",13.7,"E")
+75 SET ARASD=""
+76 if ARSDOA'=""
SET $PIECE(ARASD,"~~",1)=ARSDOA
+77 if ARCLERK'=""
SET $PIECE(ARASD,"~~",12)=ARCLERK
+78 if ARCLERKN'=""
SET $PIECE(ARASD,"~~",13)=ARCLERKN
+79 if ARDAM'=""
SET $PIECE(ARASD,"~~",17)=ARDAM
+80 SET ARSVCCON=ARDATA(FNUM,ARIEN_",",15,"E")
+81 SET ARDAPTDT=ARDATA(FNUM,ARIEN_",",22,"I")
+82 SET ARCOMM=ARDATA(FNUM,ARIEN_",",25,"I")
+83 ;S AREESTAT=ARDATA(FNUM,ARIEN_",",27,"I")
+84 SET ARMAR=$$GET1^DIQ(409.85,ARIEN_",",41)
+85 SET ARMAI=$$GET1^DIQ(409.85,ARIEN_",",42)
+86 SET ARMAN=$$GET1^DIQ(409.85,ARIEN_",",43)
+87 SET ARPC=$$WLPC^SDECAR1A(.ARDATA,ARIEN)
+88 SET ARDISPD=ARDATA(FNUM,ARIEN_",",19,"E")
+89 SET ARDISPU=ARDATA(FNUM,ARIEN_",",20,"I")
+90 SET ARDISPUN=ARDATA(FNUM,ARIEN_",",20,"E")
+91 SET APPTPTRS=$$GETAPPTS^SDECAR1A(ARIEN)
+92 SET CHILDREN=$$CHILDREN^SDECAR1A(ARIEN)
+93 SET ARMRTC=$$MRTC^SDECAR(ARIEN)
+94 SET SDPARENT=ARDATA(FNUM,ARIEN_",",43.8,"I")
+95 SET SDSENS=$$PTSEC^SDECUTL(DFN)
+96 SET (SDI,SDMTRC)=""
FOR
SET SDI=$ORDER(ARDATA(409.857,SDI))
if SDI=""
QUIT
SET SDMTRC=$SELECT(SDMTRC'="":SDMTRC_"|",1:"")_ARDATA(409.857,SDI,.01,"E")
+97 SET COUNT=COUNT+1
+98 ; 1 2 3 4 5 6 7 8 9 10 11
+99 SET STR=DFN_U_""_U_""_U_""_U_""_U_""_U_ARIEN_U_ARORIGDT_U_ARINST_U_ARINSTNM_U_ARTYPE
+100 ; 12 13 14 15 16 17 18
+101 SET STR=STR_U_ARCLIEN_U_ARCLNAME_U_ARUSER_U_ARUSRNM_U_ARPRIO_U_ARREQBY_U_ARPROV
+102 ; 19 20 21 22 23 24 25
+103 SET STR=STR_U_ARPROVNM_U_ARDAPTDT_U_ARCOMM_U_ARENPRI_U_ARMAR_U_ARMAI_U_ARMAN
+104 ; 26 27 28;29 30 31 32 33
+105 SET STR=STR_U_PRIGRP_U_ELIGIEN_U_ELIGNAME_U_SVCCONN_U_SVCCONNP_U_TYPEIEN_U_TYPENAME_U_ARPC
+106 ; 34 35 36 37 38 39 40 41 42
+107 SET STR=STR_U_ARDISPD_U_ARDISPU_U_ARDISPUN_U_ARSVCCON_U_""_U_""_U_""_U_""_U_""
+108 ; 43 44 45 46 47 48 57 (save 56 for SDSUB)
+109 SET STR=STR_U_""_U_""_U_GAF_U_AREDT_U_SDMTRC_U_SDSENS_U_U_U_U_U_U_U_U_U_ARSTOP_U_ARSTOPN_U_ARASD
+110 SET STR=STR_U_ARMRTC_U_PTPHONE_U_APPTYPE_U_SDPS_U_PRHBLOC_U_APPTPTRS_U_CHILDREN_U_SDPARENT
+111 ;alb/sat 658 - get demographics
DO ARDEMO^SDECAR1A(.STR,DFN)
+112 ; wtc patch 686 3/23/18 added for VAOS requests. Revised to store in piece 119.
SET $PIECE(STR,"^",119)=VAOSGUID
+113 ;CT *745 # OF CALLS MADE AND DATE LAST LETTER SENT
SET SDAPPT=$$CALLET^SDECAR1A(DFN,ARIEN)
+114 ;SDCALL ^ SDCLET *745
SET $PIECE(STR,"^",120)=$PIECE(SDAPPT,"^",1)
SET $PIECE(STR,"^",121)=$PIECE(SDAPPT,"^",2)
+115 ;813
SET $PIECE(STR,"^",122)=$PIECE(SDAPPT,"^",3)
+116 ;813
SET $PIECE(STR,"^",123)=$PIECE(SDAPPT,"^",4)
+117 ;813
SET $PIECE(STR,"^",124)=$PIECE(SDAPPT,"^",5)
+118 SET @RET@(COUNT)=STR_$CHAR(30)
+119 QUIT
+120 ;
ARGUID(RET,GUID) ;
+1 ;
+2 ; Return SDEC Appointment Request data for a VAOS Request GUID.
+3 ;
+4 ; wtc SD*5.3*686 4/19/2018
+5 ;
+6 ;
NEW FNUM,ARIEN,SDTMP,COUNT
+7 ;
SET RET="^TMP(""SDEC"","_$JOB_")"
+8 ;
KILL @RET
+9 ;
SET FNUM=$$FNUM^SDECAR
SET COUNT=0
+10 ;
SET ARIEN=$ORDER(^SDEC(409.85,"GUID",GUID,0))
+11 ;
DO HDR
+12 ;
IF ARIEN>0
Begin DoDot:1
+13 ;
+14 ; wtc/mbs patch 694 7/24/18 added to check if user has access to VAOS requests
+15 ;
+16 ;
NEW VAOSUSR
+17 ;
DO OWNSKEY^XUSRB(.VAOSUSR,"SDECZ REQUEST")
+18 ;
+19 ;
DO ONEPAT
End DoDot:1
+20 ;
GOTO ARX
+21 ;
