SDECEPT ;SPFO/RT,MGD,LAB,ANU - SCHEDULING ENHANCEMENTS VSE EP API ;JUN 08,2023
;;5.3;Scheduling;**669,671,694,794,809,813,823,846**;Aug 13 1993;Build 12
;;Per VHA Directive 6402, this routine should not be modified
;
;The API provides Extended Profile Appt info the VS GUI.
;INPUT - DFN required
; APP appointment date/time required
Q
;
INIT ;
S (PAT0,PAM0,CLIEN,HLF0,HLAPIEN,HLAP0)=""
;
; PAT0=Global location 0 from Patient file
; PAM0=Global location 0 from Patient Appointment Multiple
; CLIEN=Clinic IEN
; HLF0=Global location 0 from Hospital Location File
; HLAPIEN=Hospital Location Appointment Multiple IEN
; HLAP0=Global location 0 from Hospital Appointment Multiple
;
; SET HELPERS
;
S PAT0=$G(^DPT(DFN,0))
S PAM0=$G(^DPT(DFN,"S",ADT,0)) I PAM0'="" D
.S CLIEN=$P($G(PAM0),U,1) I CLIEN'="" D
..S HLF0=$G(^SC(CLIEN,0))
..S HLAPIEN=+$$FIND^SDAM2(DFN,ADT,CLIEN) I HLAPIEN'="" D
...S HLAP0=$G(^SC(CLIEN,"S",ADT,1,HLAPIEN,0))
Q
;
GETDEM(RET,DFN,ADT,SDAPPTIEN) ;
; REQUIRE DFN AND APPOINTMENT DATE TIME
Q:'$G(DFN)
Q:'$G(ADT)
S SDAPPTIEN=$G(SDAPPTIEN)
S SDRET=$$SDEXPST(.SDRET,DFN,ADT,SDAPPTIEN)
I +SDRET=-1 D Q RET
. S RET="-1^The detail for the selected record is no longer available in VistA. Select the more recent record for Expanded Entry."
;
S ADT=+ADT ;strip off extra zeros on time pwc SD*5.3*694
D INIT
;
; INITIALIZE VARIABLES
S (PATN,SSN,LAB,XRAY,EKG,PCODE,POV,ATIEN)=""
S (PAMAT,CCODE,COLL,CLN,LOA,OTH,ECODE,EGIL,PAMSC)=""
S (ENROLC,STAT,OCODE)=""
N TIMEZONE
N APPTDATA,PATCMNTS,COUNT
;
;PATN=Patient Name - Patient File [0,1]
;SSN=Formatted Social Security Number
;STAT=Status Patient Appointment Multiple - CURRENT STATUS (2.98,100)
;LAB=Date/Time of Labs - PATIENT/APPOINTMENT MULTIPLE [0,3]
;XRAY=Date/Time of x-ray - PATIENT/APPOINTMENT MULTIPLE [0,4]
;EKG=Date/Time of EKG - PATIENT/APPOINTMENT MULTIPLE [0,5]
;PCODE=Purpose of Visit Code - PATIENT/APPOINTMENT MULTIPLE [0,7]
;POV=Purpose of Visit
;ATIEN=Appointment Type IEN - PATIENT/APPOINTMENT MULTIPLE [0,16]
;PAMAT=Patient Appointment Multiple Appointment Type
;CCODE=Collateral Code - PATIENT/APPOINTMENT MULTIPLE [0,11]
;COLL=Collateral Yes or No
;CLN=Clinic Name - Hospital Location File [0,1]
;LOA=Length of Appointment - Hospital Location Appointment Multiple [0,2]
;ECODE=Eligibility Code - Hospital Location Appointment Multiple [0,10]
;EGIL=Eligibility of Appointment
;OCODE=Overbook Code - Hospital Location Appointment Multiple [QB]
;OVB=Overbook
;PATEN0=Patient Enrollment Clinic - Patient File Enrollment Clinic Multiple [B]
;ENROLC=Enrolled in Clinic Yes/No
;ERCNUM=Enrolled Clinic Number
;LPNUM=Loop Number
;
; -PATIENT FILE GLOBAL LOCATION 0
I PAT0'="" D
.S PATN=$P($G(PAT0),U,1)
.S SSN=$$LAST4SSN^SDESINPUTVALUTL(DFN)
;
; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
I PAM0'="" D
.S STAT=$$STATUS^SDAM1(DFN,ADT,CLIEN,PAM0) I STAT'="" D
..S STAT=$P(STAT,";",2)
.S LAB=$P($G(PAM0),U,3)
.S XRAY=$P($G(PAM0),U,4)
.S EKG=$P($G(PAM0),U,5)
.S PCODE=$P($G(PAM0),U,7) I PCODE'="" D
..S POV=$S(PCODE=1:"C&P",PCODE=2:"10-10",PCODE=3:"SCHEDULED",PCODE=4:"UNSCHEDULED",1:"UNKNOWN")
.S ATIEN=$P($G(PAM0),U,16) I ATIEN'="" D
..S PAMAT=$$GET1^DIQ(409.1,ATIEN,.01)
.S CCODE=$P($G(PAM0),U,11)
.S COLL="No" I CCODE=1 S COLL="Yes"
;
; -HOSPITAL LOCATION FILE GLOBAL LOCATION 0
I HLF0'="" D
.S CLN=$P($G(HLF0),U,1)
;
; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION 0
I HLAP0'="" D
.S LOA=+$P($G(HLAP0),U,2)
.S OTH=$P($G(HLAP0),U,4)
.S ECODE=$P($G(HLAP0),U,10) I ECODE'="" D
..S EGIL=$$GET1^DIQ(8,ECODE,.01)
.I ECODE="" S EGIL=$P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U)
;
; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION OB
I HLAPIEN'="" S OCODE=$G(^SC(CLIEN,"S",ADT,1,HLAPIEN,"OB")) ; pwc added check for HLAPIEN SD*5.3*694
S OVB="" I OCODE="O" S OVB="OVERBOOK"
;
; -PATIENT FILE ENROLLMENT CLINIC MULTIPLE
S ENROLC="No"
S LPNUM=0 F S LPNUM=$O(^DPT(DFN,"DE",LPNUM)) Q:LPNUM="" D
.S ERCNUM=$P($G(^DPT(DFN,"DE",LPNUM,0)),"^",1)
.Q:ERCNUM'=CLIEN
.I $P($G(^DPT(DFN,"DE",LPNUM,0)),"^",2)="" D
..S ENROLC="Yes"
..Q
;
; -CONVERT DATES TO EXTERNAL
;
; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
;
;S Y=ADT D D^DIQ S ADT=Y
S ADT=$$FMTONET^SDECDATE(ADT) ;
;I LAB'="" S Y=LAB D D^DIQ S LAB=Y
I LAB'="" S LAB=$$FMTONET^SDECDATE(LAB) ;
;I XRAY'="" S Y=XRAY D D^DIQ S XRAY=Y
I XRAY'="" S XRAY=$$FMTONET^SDECDATE(XRAY) ;
;I EKG'="" S Y=EKG D D^DIQ S EKG=Y
I EKG'="" S EKG=$$FMTONET^SDECDATE(EKG) ;
;
S TIMEZONE=$$TIMEZONEDATA^SDESUTIL($G(CLIEN)),TIMEZONE=$P($G(TIMEZONE),U)
;
;ANU
D GETPATCOMMENTS^SDESAPPTDATA(.APPTDATA,SDAPPTIEN)
S COUNT=1
S PATCMNTS=APPTDATA("PatientComments",1)
F S COUNT=$O(APPTDATA("PatientComments",COUNT)) Q:'COUNT D
.S PATCMNTS=PATCMNTS_U_APPTDATA("PatientComments",COUNT)
;
S RET=PATN_U_CLN_U_SSN_U_ADT_U_STAT_U_POV_U_LOA_U_PAMAT_U_LAB_U_EGIL_U_XRAY_U_OVB_U_EKG_U_COLL_U_OTH_U_ENROLC_U_TIMEZONE_U_$G(PATCMNTS)_U
;
D EXIT
Q
;
SDEXPST(SDRET,DFN,ADT,SDAPPTIEN) ;
N SDAPPT,SDRTN,SDNEXTIEN,SDCAN
S SDRTN="" ; Appt can be expanded
S SDAPPT="",ADT=+ADT
F S SDAPPT=$O(^SDEC(409.84,"APTDT",DFN,ADT,SDAPPT)) Q:'SDAPPT D Q:SDRTN'=""
. Q:SDAPPT'=SDAPPTIEN
. S SDCAN=($$GET1^DIQ(409.84,SDAPPT,.12,"I")'="")
. S SDNEXTIEN=$O(^SDEC(409.84,"APTDT",DFN,ADT,SDAPPT))
. ; Current Appt is cancelled and there is another APPT
. I SDCAN,SDNEXTIEN S SDRTN=-1 Q
. ; Current Appt is cancelled & no other Appt
. I SDCAN,'SDNEXTIEN S SDRTN=0 Q
. ; Current Appt is NOT cancelled so there can't be other Appt for same Date/Time
. I 'SDCAN,'SDNEXTIEN S SDRTN=0 Q
S SDRET=SDRTN
Q SDRET
;
GETEVT(RET,DFN,ADT) ;
; REQUIRE DFN AND APPOINTMENT DATE TIME
Q:'$G(DFN)
Q:'$G(ADT)
;
S ADT=+ADT ;strip off extra zeros on time pwc SD*5.3*694
D INIT
;
; INITIALIZE VARIABLES
S (AMUIEN,AMU,AMD,HLAPC,CID,CIUIEN,CIUN,COD,COUIEN,CREAC)=""
S (COUN,COED,NCD,NCUIEN,NCUN,CANREA,RBD,CANREM,AMUN,HLPAC)=""
;
;AMUIEN=Appointment Made User IEN - Hospital Location Appointment Multiple [0,6]
;AMUN=Appointment Made User Name - New Person File Field .01
;AMD=Appointment Made Date - Hospital Location Appointment Multiple [0,7]
;HLAPC=Global location C from Hospital Location Appointment Multiple
;CID=Check-in Date - Hospital Location Appointment Multiple [C,1]
;CIUIEN=Check-in User IEN - Hospital Location Appointment Multiple [C,2]
;CIUN=Check-in User Name - New Person File Field .01
;COD=Check Out Date - Hospital Location Appointment Multiple [C,3]
;COUIEN=Check Out User IEN - Hospital Location Appointment Multiple [C,4]
;COUN=Check Out User Name - New Person File Field .01
;COED=Check Out Entered Date - Hospital Location Appointment Multiple [C,3]
;NCD=No-Show/Cancel Date - PATIENT/APPOINTMENT MULTIPLE [0,14]
;NCUIEN=No-Show/Cancel User IEN - PATIENT/APPOINTMENT MULTIPLE [0,12]
;NCUN=No-Show/Cancel User Name - New Person File Field .01
;CREAC=Cancel Reason Code - PATIENT/APPOINTMENT MULTIPLE [0,15]
;CANREA=Cancel Reason - CANCELLATION REASONS [0,1]
;RBD=Rebook Date - PATIENT/APPOINTMENT MULTIPLE [0,10]
;CANREM=Cancel Remarks - PATIENT/APPOINTMENT MULTIPLE [R,1]
;
; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION 0
I HLAP0'="" D
.S AMUIEN=$P($G(HLAP0),U,6) I AMUIEN'="" D
..S AMUN=$$GET1^DIQ(200,AMUIEN,.01,"E")
.S AMD=$P($G(HLAP0),U,7)
;
; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION C
I HLAPIEN'="" S HLAPC=$G(^SC(CLIEN,"S",ADT,1,HLAPIEN,"C")) I HLAPC'="" D
.S CID=$P($G(HLAPC),U,1) I CID'="" D
..S CIUIEN=$P($G(HLAPC),U,2) I CIUIEN'="" D
...S CIUN=$$GET1^DIQ(200,CIUIEN,.01,"E")
.S COD=$P($G(HLAPC),U,3) I COD'="" D
..S COUIEN=$P($G(HLAPC),U,4) I COUIEN'="" D
...S COUN=$$GET1^DIQ(200,COUIEN,.01,"E")
..S COED=$P($G(HLAPC),U,6)
;
; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
I PAM0'="" D
.S NCD=$P($G(PAM0),U,14) I NCD'="" D
..S NCUIEN=$P($G(PAM0),U,12) I NCUIEN'="" D
...S NCUN=$$GET1^DIQ(200,NCUIEN,.01,"E")
.S CREAC=$P($G(PAM0),U,15) I NCUIEN'="" D
..S CANREA=$$GET1^DIQ(409.2,CREAC,.01)
.S RBD=$P($G(PAM0),U,10)
I AMUN="" D
.S AMUIEN=$P($G(PAM0),U,18) I AMUIEN'="" D
..S AMUN=$$GET1^DIQ(200,AMUIEN,.01,"E")
I AMD="" D
.S AMD=$P($G(PAM0),U,19)
;
; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION R
S PAMR=$G(^DPT(DFN,"S",ADT,"R")) I PAMR'="" D
.S CANREM=$P($G(PAMR),U,1)
;
; -CONVERT DATES TO EXTERNAL
;
; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
;
;I AMD'="" S Y=AMD D D^DIQ S AMD=Y
I AMD'="" S AMD=$$FMTONET^SDECDATE(AMD) ;
;I CID'="" S Y=CID D D^DIQ S CID=Y
I CID'="" S CID=$$FMTONET^SDECDATE(CID) ;
;I COD'="" S Y=COD D D^DIQ S COD=Y
I COD'="" S COD=$$FMTONET^SDECDATE(COD) ;
;I COED'="" S Y=COED D D^DIQ S COED=Y
I COED'="" S COED=$$FMTONET^SDECDATE(COED) ;
;I NCD'="" S Y=NCD D D^DIQ S NCD=Y
I NCD'="" S NCD=$$FMTONET^SDECDATE(NCD) ;
;
S RET=AMD_U_AMUN_U_CID_U_CIUN_U_COD_U_COUN_U_COED_U_NCD_U_NCUN_U_CANREA_U_CANREM_U_RBD
;
D EXIT
Q
;
GETWT(RET,DFN,ADT) ;
; REQUIRE DFN AND APPOINTMENT DATE TIME
Q:'$G(DFN)
Q:'$G(ADT)
;
S ADT=+ADT ;strip off extra zeros on time pwc SD*5.3*694
D INIT
;
S (REQTC,REQT,NATCODE,NAT,AMD,PAM1,CID,FUVCODE,FUV,CWT1,CWT2)=""
;
;REQTC=Request Type Code - Patient File Appointment Multiple [0,25]
;REQT=Request Type
;NATCODE=Next Available Type Code - Patient File Appointment Multiple [0,26]
;NAT=Next Available Type
;AMD=Appointment Made Date - Patient File Appointment Multiple [0,19]
;PAM1=Global Location 1 of the Patient File Appointment Multiple
;CID=Clinic Indicated Date/Preferred Date - Patient File Appointment Multiple [1,1]
;FUVCODE=Follow-Up Visit Code 1=Yes 0=No - Patient File Appointment Multiple [1,2]
;FUV=Follow-Up Visit
;CWT1=Clinic Wait Time 1
;CWT2=Clinic Wait Time 2
;
; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
I PAM0'="" D
.S REQTC=$P($G(PAM0),U,25) I REQTC'="" D
..I REQTC="N" S REQT="'NEXT AVAILABLE' APPT."
..I REQTC="C" S REQT="OTHER THAN 'NEXT AVA.' (CLINICIAN REQ.)"
..I REQTC="P" S REQT="OTHER THAN 'NEXT AVA.' (PATIENT REQ.)"
..I REQTC="W" S REQT="WALKIN APPT."
..I REQTC="M" S REQT="MULTIPLE APPT. BOOKING"
..I REQTC="A" S REQT="AUTO REBOOK"
..I REQTC="O" S REQT="OTHER THAN 'NEXT AVA.' APPT."
.S NATCODE=$P($G(PAM0),U,26) I NATCODE'="" D
..I NATCODE=0 S NAT="NOT INDICATED TO BE A 'NEXT AVA.' APPT."
..I NATCODE=1 S NAT="'NEXT AVA.' APPT. INDICATED BY USER"
..I NATCODE=3 S NAT="'NEXT AVA.' APPT. INDICATED BY CALCULATION"
..I NATCODE=4 S NAT="'NEXT AVA.' APPT. INDICATED BY USER & CALCULATION"
.S AMD=$P($G(PAM0),U,19)
;
; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 1
S PAM1=$G(^DPT(DFN,"S",ADT,1)) I PAM1'="" D
.S CID=$P($G(PAM1),U,1)
.S FUVCODE=$P($G(PAM1),U,2)
.S FUV="No" I FUVCODE=1 S FUV="Yes"
;
; CALULATE WAIT TIMES
S (X,X1,X2)=""
I AMD'="" D
.S X1=ADT S X2=AMD D ^%DTC S CWT1=X
I CID'="" D
.S X1=ADT S X2=CID D ^%DTC S CWT2=X
;
; -CONVERT DATES TO EXTERNAL
;
; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
;
;I CID'="" S Y=CID D D^DIQ S CID=Y
I CID'="" S CID=$$FMTONET^SDECDATE(CID) ;
;
S RET=REQT_U_NAT_U_CID_U_FUV_U_CWT1_U_CWT2
;
D EXIT
Q
;
;STATUS, LAST ADMIT/LODGER DATE, LAST DISCHARGE/LODGER DATE
INP ;
Q:'$G(DFN)
;
S (LADMT,LDIS,DNUM,STAT,SDST,SDSTA,REN,A)=""
I '$D(^DGPM("C",DFN)) S LSTAT="NO INPT./LOD. ACT." Q
;
S VAIP("D")="L",VAIP("L")="" D INP^DGPMV10
S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2)),SDST=$S('A:"IN",1:"")_"ACTIVE ",SDSTA=$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT")
S STAT="" S STAT=SDST_SDSTA
S LADMT="" S LADMT=$P($G(DGPMVI(13,1)),"^",2)
S DNUM="" S DNUM=$G(DGPMV1(17)) I DNUM'="" D
.S LDIS="" S LDIS=$$GET1^DIQ(405,DNUM,.01)
Q
GETPTIN(RET,DFN,ADT) ;
;REQUIRE DFN AND APPOINTMENT DATE TIME
Q:'$G(DFN)
Q:'$G(ADT)
;
S ADT=+ADT ;strip off extra zeros on time pwc SD*5.3*694
D INIT
;
S (DOB,SSN,SEX,MARSIEN,MARS,RELGP,PAT36,PELIG,POS,SADDR1,SWASIAC)=""
S (SADDR2,SADDR3,CITY,STATEN,STATE,CNTY,ADDR,PHN,CPHN,PGER,EMAIL,RADEXC)=""
S (RADEX,STAT,POW,LADMT,AOEXLC,AOEXL,LDIS,CMBTVC,CMBTV,CMBTVED,PROJ112)=""
S (PROCODE,SWASIA,PAT36,PAT11,PAT13,PAT36,PAT52,PAT321,PAT322,POWCODE)=""
S (RELGPN,PELIGN,POSN)=""
;
;DOB=Date Of Birth - Patient File [0,3]
;SSN=Formatted Social Security Number
;SEX=Male or Female - Patient File [0,2]
;MARSIEN=Marital Status IEN - Patient File [0,5]
;MARS=Marital Status - Marital Status File (11) Field .01
;RELGPN=Religious Preference IEN - Patient File [0,8]
;RELGP=Religious Preference - file 13 field .01 (Name)
;PELIGN=Primary Eligibility IEN - Patient File [.36,1]
;PELIG=Primary Eligibility - File 8 field .01 (name)
;POSN=Period of Service IEN
;POS=Period of Service - File 21 Field .01 (Name)
;SADDR1=Street Address 1 - Patient File [.11,1]
;SADDR2=Street Address 2 - Patient File [.11,2]
;SADDR3=Street Address 2 - Patient File [.11,3]
;CITY=City - Patient File [.11,4]
;STATEN=State IEN - Patient File [.11,5]
;STATE=State - State File (5) Field .01
;CNTYIEN=Country IEN - Patient File [.11,10]
;CNTY=Country - Country Code File (779.004) Field .01
;ADDR=Address
;PHN=Phone Number - Patient File [.13,1]
;CPHN=Cell Phone Number - Patient File [.13,4]
;PGER=Pager Number - Patient File [.13,5]
;EMAIL=Email Address - Patient File [.13,3]
;RADEXC=Radiation Exposure CODE Y=Yes N=No U=Unknown - Patient File [.321,3]
;RADEX=Radiation Exposure
;
;STAT=Status ???
;
;POWCODE=Prisoner Of War CODE Y=Yes N=No U=Unknown - Patient File [.52,5]
;POW=Prisoner Of War
;
;LADMT=Last Admit/Lodger Date ???
;
;AOEXLC=Agent Orange Exposure Location CODE K=Korean DMZ V=Vietnam O=Other - Patient File [.321,13]
;AOEXL=Agent Orange Exposure Location
;
;LDIS=Last Discharge/Lodger Date ???
;
;CMBTVC=Combat Veteran CODE Y=Yes N=No - Patient File [.52,11]
;CMBTV=Combat Veteran
;CMBTVED=Combat Veteran End Date - Patient File [.52,14]
;PROCODE=Project 112/SHAD CODE 0=No 1=Yes - Patient File [.321,15]
;PROJ112=Project 112/SHAD
;SWASIAC=SW Asia Conditions Code Y=Yes N=No U=Unknown - Patient File [.322,13]
;SWASIA=SW Asia Conditions
;
; -PATIENT FILE GLOBAL LOCATION 0
I PAT0'="" D
.S DOB=$P($G(PAT0),U,3)
.S SSN=$$LAST4SSN^SDESINPUTVALUTL(DFN)
.S SEXCODE=$P($G(PAT0),U,2) I SEXCODE'="" D
..I SEXCODE="M" S SEX="Male"
..I SEXCODE="F" S SEX="Female"
.S MARSIEN=$P($G(PAT0),U,5) I MARSIEN'="" D
..S MARS=$$GET1^DIQ(11,MARSIEN,.01)
.S RELGPN=$P($G(PAT0),U,8) I RELGPN'="" D
..S RELGP=$$GET1^DIQ(13,RELGPN,.01)
;
; -PATIENT FILE GLOBAL LOCATION .11
S PAT11=$G(^DPT(DFN,.11)) I PAT11'="" D
.S SADDR1=$P($G(PAT11),U,1)
.S SADDR2=$P($G(PAT11),U,2)
.S SADDR3=$P($G(PAT11),U,3)
.S CITY=$P($G(PAT11),U,4)
.S STATEN=$P($G(PAT11),U,5) I STATEN'="" D
..S STATE=$$GET1^DIQ(5,STATEN,.01)
.S ZCODE=$P($G(PAT11),U,6)
.S CNTYIEN=$P($G(PAT11),U,10) I CNTYIEN'="" D
..S CNTY=$$GET1^DIQ(779.004,CNTYIEN,.01)
.S SADDR=SADDR1 I SADDR2'="" D
..S SADDR=SADDR1_" "_SADDR2 I SADDR3'="" D
...S SADDR=SADDR1_" "_SADDR2_" "_SADDR3
.S ADDR=SADDR_" "_CITY_", "_STATE_" "_ZCODE_" "_CNTY
;
; -PATIENT FILE GLOBAL LOCATION .13
S PAT13=$G(^DPT(DFN,.13)) I PAT13'="" D
.S PHN=$P($G(PAT13),U,1)
.S CPHN=$P($G(PAT13),U,4)
.S PGER=$P($G(PAT13),U,5)
.S EMAIL=$P($G(PAT13),U,3)
;
; -PATIENT FILE GLOBAL LOCATION .36
S PAT36=$G(^DPT(DFN,.36)) I PAT36'="" D
.S PELIGN=$P($G(PAT36),U,1) I PELIGN'="" D
..S PELIG=$$GET1^DIQ(8,PELIGN,.01)
;
; -PATIENT FILE GLOBAL LOCATION .52
S PAT52=$G(^DPT(DFN,.52)) I PAT52'="" D
.S POWCODE=$P($G(PAT52),U,5) I POWCODE'="" D
..I POWCODE="Y" S POW="Yes"
..I POWCODE="N" S POW="No"
..I POWCODE="U" S POW="Unknown"
.S CMBTVC=$P($G(PAT52),U,11) I CMBTVC'="" D
..S CMBTV="No"
..I CMBTVC="Y" S CMBTV="Yes"
.S CMBTVED=$P($G(PAT52),U,14) I CMBTV="No" D
..S CMBTVED="N/A"
;
; -PATIENT FILE GLOBAL LOCATION .321
S PAT321=$G(^DPT(DFN,.52)) I PAT321'="" D
.S RADEXC=$P($G(PAT321),U,3) I RADEXC'="" D
..I RADEXC="Y" S RADEX="Yes"
..I RADEXC="N" S RADEX="No"
..I RADEXC="U" S RADEX="Unknown"
.S AOEXLC=$P($G(PAT321),U,13) I AOEXLC'="" D
..I AOEXLC="K" S AOEXL="Korean DMZ"
..I AOEXLC="V" S AOEXL="Vietnam"
..I AOEXLC="O" S AOEXL="Other (Not Korean DMZ or Vietnam)"
.S PROCODE=$P($G(PAT321),U,15) I PROCODE'="" D
..I PROCODE=2 S PROJ112="No"
..I PROCODE=1 S PROJ112="Yes"
;
; -PATIENT FILE GLOBAL LOCATION .322
S PAT322=$G(^DPT(DFN,.52)) I PAT322'="" D
.S SWASIAC=$P($G(PAT322),U,13) I SWASIAC'="" D
..I SWASIAC="Y" S SWASIA="Yes"
..I SWASIAC="N" S SWASIA="No"
..I SWASIAC="U" S SWASIA="Unknown"
;
; -CONVERT DATES TO EXTERNAL
I DOB'="" S Y=DOB D D^DIQ S DOB=Y
;
; -PERIOD OF SERVICE
S (POSN,POS)="" S POSN=$$GET1^DIQ(2,DFN_",",.323,"I") I POSN'="" S POS=$$GET1^DIQ(21,POSN,.01,"E")
;
; -GET STAT, LADMT, LDIS
D INP
;
S RET=DOB_U_SSN_U_SEX_U_MARS_U_RELGP_U_PELIG_U_POS_U_ADDR_U_PHN_U_CPHN_U_PGER_U_EMAIL_U_RADEX_U_STAT_U_POW_U_LADMT_U_AOEXL_U_LDIS_U_CMBTV_U_CMBTVED_U_PROJ112_U_SWASIA
;
D EXIT
Q
;
EXIT ;
K PAT0,PAM0,CLIEN,HLF0,HLAPIEN,HLAP0,PAMS,PCODE,ATIEN,CCODE,ECODE,PAMSC
K AMUIEN,AMU,HLAPC,CIUIEN,COUIEN,NCUIEN,PAT36,SADDR1,SWASIAC,SADDR2,SADDR3
K CITY,STATEN,STATE,CNTY,RADEXC,AOEXLC,CMBTVC,PROCODE,PAT36,PAT11,PAT13,PAT52
K PAT321,PAT322,ENROLC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECEPT 17682 printed Sep 23, 2025@20:28:29 Page 2
SDECEPT ;SPFO/RT,MGD,LAB,ANU - SCHEDULING ENHANCEMENTS VSE EP API ;JUN 08,2023
+1 ;;5.3;Scheduling;**669,671,694,794,809,813,823,846**;Aug 13 1993;Build 12
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ;The API provides Extended Profile Appt info the VS GUI.
+5 ;INPUT - DFN required
+6 ; APP appointment date/time required
+7 QUIT
+8 ;
INIT ;
+1 SET (PAT0,PAM0,CLIEN,HLF0,HLAPIEN,HLAP0)=""
+2 ;
+3 ; PAT0=Global location 0 from Patient file
+4 ; PAM0=Global location 0 from Patient Appointment Multiple
+5 ; CLIEN=Clinic IEN
+6 ; HLF0=Global location 0 from Hospital Location File
+7 ; HLAPIEN=Hospital Location Appointment Multiple IEN
+8 ; HLAP0=Global location 0 from Hospital Appointment Multiple
+9 ;
+10 ; SET HELPERS
+11 ;
+12 SET PAT0=$GET(^DPT(DFN,0))
+13 SET PAM0=$GET(^DPT(DFN,"S",ADT,0))
IF PAM0'=""
Begin DoDot:1
+14 SET CLIEN=$PIECE($GET(PAM0),U,1)
IF CLIEN'=""
Begin DoDot:2
+15 SET HLF0=$GET(^SC(CLIEN,0))
+16 SET HLAPIEN=+$$FIND^SDAM2(DFN,ADT,CLIEN)
IF HLAPIEN'=""
Begin DoDot:3
+17 SET HLAP0=$GET(^SC(CLIEN,"S",ADT,1,HLAPIEN,0))
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
GETDEM(RET,DFN,ADT,SDAPPTIEN) ;
+1 ; REQUIRE DFN AND APPOINTMENT DATE TIME
+2 if '$GET(DFN)
QUIT
+3 if '$GET(ADT)
QUIT
+4 SET SDAPPTIEN=$GET(SDAPPTIEN)
+5 SET SDRET=$$SDEXPST(.SDRET,DFN,ADT,SDAPPTIEN)
+6 IF +SDRET=-1
Begin DoDot:1
+7 SET RET="-1^The detail for the selected record is no longer available in VistA. Select the more recent record for Expanded Entry."
End DoDot:1
QUIT RET
+8 ;
+9 ;strip off extra zeros on time pwc SD*5.3*694
SET ADT=+ADT
+10 DO INIT
+11 ;
+12 ; INITIALIZE VARIABLES
+13 SET (PATN,SSN,LAB,XRAY,EKG,PCODE,POV,ATIEN)=""
+14 SET (PAMAT,CCODE,COLL,CLN,LOA,OTH,ECODE,EGIL,PAMSC)=""
+15 SET (ENROLC,STAT,OCODE)=""
+16 NEW TIMEZONE
+17 NEW APPTDATA,PATCMNTS,COUNT
+18 ;
+19 ;PATN=Patient Name - Patient File [0,1]
+20 ;SSN=Formatted Social Security Number
+21 ;STAT=Status Patient Appointment Multiple - CURRENT STATUS (2.98,100)
+22 ;LAB=Date/Time of Labs - PATIENT/APPOINTMENT MULTIPLE [0,3]
+23 ;XRAY=Date/Time of x-ray - PATIENT/APPOINTMENT MULTIPLE [0,4]
+24 ;EKG=Date/Time of EKG - PATIENT/APPOINTMENT MULTIPLE [0,5]
+25 ;PCODE=Purpose of Visit Code - PATIENT/APPOINTMENT MULTIPLE [0,7]
+26 ;POV=Purpose of Visit
+27 ;ATIEN=Appointment Type IEN - PATIENT/APPOINTMENT MULTIPLE [0,16]
+28 ;PAMAT=Patient Appointment Multiple Appointment Type
+29 ;CCODE=Collateral Code - PATIENT/APPOINTMENT MULTIPLE [0,11]
+30 ;COLL=Collateral Yes or No
+31 ;CLN=Clinic Name - Hospital Location File [0,1]
+32 ;LOA=Length of Appointment - Hospital Location Appointment Multiple [0,2]
+33 ;ECODE=Eligibility Code - Hospital Location Appointment Multiple [0,10]
+34 ;EGIL=Eligibility of Appointment
+35 ;OCODE=Overbook Code - Hospital Location Appointment Multiple [QB]
+36 ;OVB=Overbook
+37 ;PATEN0=Patient Enrollment Clinic - Patient File Enrollment Clinic Multiple [B]
+38 ;ENROLC=Enrolled in Clinic Yes/No
+39 ;ERCNUM=Enrolled Clinic Number
+40 ;LPNUM=Loop Number
+41 ;
+42 ; -PATIENT FILE GLOBAL LOCATION 0
+43 IF PAT0'=""
Begin DoDot:1
+44 SET PATN=$PIECE($GET(PAT0),U,1)
+45 SET SSN=$$LAST4SSN^SDESINPUTVALUTL(DFN)
End DoDot:1
+46 ;
+47 ; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
+48 IF PAM0'=""
Begin DoDot:1
+49 SET STAT=$$STATUS^SDAM1(DFN,ADT,CLIEN,PAM0)
IF STAT'=""
Begin DoDot:2
+50 SET STAT=$PIECE(STAT,";",2)
End DoDot:2
+51 SET LAB=$PIECE($GET(PAM0),U,3)
+52 SET XRAY=$PIECE($GET(PAM0),U,4)
+53 SET EKG=$PIECE($GET(PAM0),U,5)
+54 SET PCODE=$PIECE($GET(PAM0),U,7)
IF PCODE'=""
Begin DoDot:2
+55 SET POV=$SELECT(PCODE=1:"C&P",PCODE=2:"10-10",PCODE=3:"SCHEDULED",PCODE=4:"UNSCHEDULED",1:"UNKNOWN")
End DoDot:2
+56 SET ATIEN=$PIECE($GET(PAM0),U,16)
IF ATIEN'=""
Begin DoDot:2
+57 SET PAMAT=$$GET1^DIQ(409.1,ATIEN,.01)
End DoDot:2
+58 SET CCODE=$PIECE($GET(PAM0),U,11)
+59 SET COLL="No"
IF CCODE=1
SET COLL="Yes"
End DoDot:1
+60 ;
+61 ; -HOSPITAL LOCATION FILE GLOBAL LOCATION 0
+62 IF HLF0'=""
Begin DoDot:1
+63 SET CLN=$PIECE($GET(HLF0),U,1)
End DoDot:1
+64 ;
+65 ; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION 0
+66 IF HLAP0'=""
Begin DoDot:1
+67 SET LOA=+$PIECE($GET(HLAP0),U,2)
+68 SET OTH=$PIECE($GET(HLAP0),U,4)
+69 SET ECODE=$PIECE($GET(HLAP0),U,10)
IF ECODE'=""
Begin DoDot:2
+70 SET EGIL=$$GET1^DIQ(8,ECODE,.01)
End DoDot:2
+71 IF ECODE=""
SET EGIL=$PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),U)
End DoDot:1
+72 ;
+73 ; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION OB
+74 ; pwc added check for HLAPIEN SD*5.3*694
IF HLAPIEN'=""
SET OCODE=$GET(^SC(CLIEN,"S",ADT,1,HLAPIEN,"OB"))
+75 SET OVB=""
IF OCODE="O"
SET OVB="OVERBOOK"
+76 ;
+77 ; -PATIENT FILE ENROLLMENT CLINIC MULTIPLE
+78 SET ENROLC="No"
+79 SET LPNUM=0
FOR
SET LPNUM=$ORDER(^DPT(DFN,"DE",LPNUM))
if LPNUM=""
QUIT
Begin DoDot:1
+80 SET ERCNUM=$PIECE($GET(^DPT(DFN,"DE",LPNUM,0)),"^",1)
+81 if ERCNUM'=CLIEN
QUIT
+82 IF $PIECE($GET(^DPT(DFN,"DE",LPNUM,0)),"^",2)=""
Begin DoDot:2
+83 SET ENROLC="Yes"
+84 QUIT
End DoDot:2
End DoDot:1
+85 ;
+86 ; -CONVERT DATES TO EXTERNAL
+87 ;
+88 ; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
+89 ;
+90 ;S Y=ADT D D^DIQ S ADT=Y
+91 ;
SET ADT=$$FMTONET^SDECDATE(ADT)
+92 ;I LAB'="" S Y=LAB D D^DIQ S LAB=Y
+93 ;
IF LAB'=""
SET LAB=$$FMTONET^SDECDATE(LAB)
+94 ;I XRAY'="" S Y=XRAY D D^DIQ S XRAY=Y
+95 ;
IF XRAY'=""
SET XRAY=$$FMTONET^SDECDATE(XRAY)
+96 ;I EKG'="" S Y=EKG D D^DIQ S EKG=Y
+97 ;
IF EKG'=""
SET EKG=$$FMTONET^SDECDATE(EKG)
+98 ;
+99 SET TIMEZONE=$$TIMEZONEDATA^SDESUTIL($GET(CLIEN))
SET TIMEZONE=$PIECE($GET(TIMEZONE),U)
+100 ;
+101 ;ANU
+102 DO GETPATCOMMENTS^SDESAPPTDATA(.APPTDATA,SDAPPTIEN)
+103 SET COUNT=1
+104 SET PATCMNTS=APPTDATA("PatientComments",1)
+105 FOR
SET COUNT=$ORDER(APPTDATA("PatientComments",COUNT))
if 'COUNT
QUIT
Begin DoDot:1
+106 SET PATCMNTS=PATCMNTS_U_APPTDATA("PatientComments",COUNT)
End DoDot:1
+107 ;
+108 SET RET=PATN_U_CLN_U_SSN_U_ADT_U_STAT_U_POV_U_LOA_U_PAMAT_U_LAB_U_EGIL_U_XRAY_U_OVB_U_EKG_U_COLL_U_OTH_U_ENROLC_U_TIMEZONE_U_$GET(PATCMNTS)_U
+109 ;
+110 DO EXIT
+111 QUIT
+112 ;
SDEXPST(SDRET,DFN,ADT,SDAPPTIEN) ;
+1 NEW SDAPPT,SDRTN,SDNEXTIEN,SDCAN
+2 ; Appt can be expanded
SET SDRTN=""
+3 SET SDAPPT=""
SET ADT=+ADT
+4 FOR
SET SDAPPT=$ORDER(^SDEC(409.84,"APTDT",DFN,ADT,SDAPPT))
if 'SDAPPT
QUIT
Begin DoDot:1
+5 if SDAPPT'=SDAPPTIEN
QUIT
+6 SET SDCAN=($$GET1^DIQ(409.84,SDAPPT,.12,"I")'="")
+7 SET SDNEXTIEN=$ORDER(^SDEC(409.84,"APTDT",DFN,ADT,SDAPPT))
+8 ; Current Appt is cancelled and there is another APPT
+9 IF SDCAN
IF SDNEXTIEN
SET SDRTN=-1
QUIT
+10 ; Current Appt is cancelled & no other Appt
+11 IF SDCAN
IF 'SDNEXTIEN
SET SDRTN=0
QUIT
+12 ; Current Appt is NOT cancelled so there can't be other Appt for same Date/Time
+13 IF 'SDCAN
IF 'SDNEXTIEN
SET SDRTN=0
QUIT
End DoDot:1
if SDRTN'=""
QUIT
+14 SET SDRET=SDRTN
+15 QUIT SDRET
+16 ;
GETEVT(RET,DFN,ADT) ;
+1 ; REQUIRE DFN AND APPOINTMENT DATE TIME
+2 if '$GET(DFN)
QUIT
+3 if '$GET(ADT)
QUIT
+4 ;
+5 ;strip off extra zeros on time pwc SD*5.3*694
SET ADT=+ADT
+6 DO INIT
+7 ;
+8 ; INITIALIZE VARIABLES
+9 SET (AMUIEN,AMU,AMD,HLAPC,CID,CIUIEN,CIUN,COD,COUIEN,CREAC)=""
+10 SET (COUN,COED,NCD,NCUIEN,NCUN,CANREA,RBD,CANREM,AMUN,HLPAC)=""
+11 ;
+12 ;AMUIEN=Appointment Made User IEN - Hospital Location Appointment Multiple [0,6]
+13 ;AMUN=Appointment Made User Name - New Person File Field .01
+14 ;AMD=Appointment Made Date - Hospital Location Appointment Multiple [0,7]
+15 ;HLAPC=Global location C from Hospital Location Appointment Multiple
+16 ;CID=Check-in Date - Hospital Location Appointment Multiple [C,1]
+17 ;CIUIEN=Check-in User IEN - Hospital Location Appointment Multiple [C,2]
+18 ;CIUN=Check-in User Name - New Person File Field .01
+19 ;COD=Check Out Date - Hospital Location Appointment Multiple [C,3]
+20 ;COUIEN=Check Out User IEN - Hospital Location Appointment Multiple [C,4]
+21 ;COUN=Check Out User Name - New Person File Field .01
+22 ;COED=Check Out Entered Date - Hospital Location Appointment Multiple [C,3]
+23 ;NCD=No-Show/Cancel Date - PATIENT/APPOINTMENT MULTIPLE [0,14]
+24 ;NCUIEN=No-Show/Cancel User IEN - PATIENT/APPOINTMENT MULTIPLE [0,12]
+25 ;NCUN=No-Show/Cancel User Name - New Person File Field .01
+26 ;CREAC=Cancel Reason Code - PATIENT/APPOINTMENT MULTIPLE [0,15]
+27 ;CANREA=Cancel Reason - CANCELLATION REASONS [0,1]
+28 ;RBD=Rebook Date - PATIENT/APPOINTMENT MULTIPLE [0,10]
+29 ;CANREM=Cancel Remarks - PATIENT/APPOINTMENT MULTIPLE [R,1]
+30 ;
+31 ; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION 0
+32 IF HLAP0'=""
Begin DoDot:1
+33 SET AMUIEN=$PIECE($GET(HLAP0),U,6)
IF AMUIEN'=""
Begin DoDot:2
+34 SET AMUN=$$GET1^DIQ(200,AMUIEN,.01,"E")
End DoDot:2
+35 SET AMD=$PIECE($GET(HLAP0),U,7)
End DoDot:1
+36 ;
+37 ; -HOSPITAL LOCATION/APPOINTMENT/PATIENT MULTIPLE GLOBAL LOCATION C
+38 IF HLAPIEN'=""
SET HLAPC=$GET(^SC(CLIEN,"S",ADT,1,HLAPIEN,"C"))
IF HLAPC'=""
Begin DoDot:1
+39 SET CID=$PIECE($GET(HLAPC),U,1)
IF CID'=""
Begin DoDot:2
+40 SET CIUIEN=$PIECE($GET(HLAPC),U,2)
IF CIUIEN'=""
Begin DoDot:3
+41 SET CIUN=$$GET1^DIQ(200,CIUIEN,.01,"E")
End DoDot:3
End DoDot:2
+42 SET COD=$PIECE($GET(HLAPC),U,3)
IF COD'=""
Begin DoDot:2
+43 SET COUIEN=$PIECE($GET(HLAPC),U,4)
IF COUIEN'=""
Begin DoDot:3
+44 SET COUN=$$GET1^DIQ(200,COUIEN,.01,"E")
End DoDot:3
+45 SET COED=$PIECE($GET(HLAPC),U,6)
End DoDot:2
End DoDot:1
+46 ;
+47 ; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
+48 IF PAM0'=""
Begin DoDot:1
+49 SET NCD=$PIECE($GET(PAM0),U,14)
IF NCD'=""
Begin DoDot:2
+50 SET NCUIEN=$PIECE($GET(PAM0),U,12)
IF NCUIEN'=""
Begin DoDot:3
+51 SET NCUN=$$GET1^DIQ(200,NCUIEN,.01,"E")
End DoDot:3
End DoDot:2
+52 SET CREAC=$PIECE($GET(PAM0),U,15)
IF NCUIEN'=""
Begin DoDot:2
+53 SET CANREA=$$GET1^DIQ(409.2,CREAC,.01)
End DoDot:2
+54 SET RBD=$PIECE($GET(PAM0),U,10)
End DoDot:1
+55 IF AMUN=""
Begin DoDot:1
+56 SET AMUIEN=$PIECE($GET(PAM0),U,18)
IF AMUIEN'=""
Begin DoDot:2
+57 SET AMUN=$$GET1^DIQ(200,AMUIEN,.01,"E")
End DoDot:2
End DoDot:1
+58 IF AMD=""
Begin DoDot:1
+59 SET AMD=$PIECE($GET(PAM0),U,19)
End DoDot:1
+60 ;
+61 ; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION R
+62 SET PAMR=$GET(^DPT(DFN,"S",ADT,"R"))
IF PAMR'=""
Begin DoDot:1
+63 SET CANREM=$PIECE($GET(PAMR),U,1)
End DoDot:1
+64 ;
+65 ; -CONVERT DATES TO EXTERNAL
+66 ;
+67 ; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
+68 ;
+69 ;I AMD'="" S Y=AMD D D^DIQ S AMD=Y
+70 ;
IF AMD'=""
SET AMD=$$FMTONET^SDECDATE(AMD)
+71 ;I CID'="" S Y=CID D D^DIQ S CID=Y
+72 ;
IF CID'=""
SET CID=$$FMTONET^SDECDATE(CID)
+73 ;I COD'="" S Y=COD D D^DIQ S COD=Y
+74 ;
IF COD'=""
SET COD=$$FMTONET^SDECDATE(COD)
+75 ;I COED'="" S Y=COED D D^DIQ S COED=Y
+76 ;
IF COED'=""
SET COED=$$FMTONET^SDECDATE(COED)
+77 ;I NCD'="" S Y=NCD D D^DIQ S NCD=Y
+78 ;
IF NCD'=""
SET NCD=$$FMTONET^SDECDATE(NCD)
+79 ;
+80 SET RET=AMD_U_AMUN_U_CID_U_CIUN_U_COD_U_COUN_U_COED_U_NCD_U_NCUN_U_CANREA_U_CANREM_U_RBD
+81 ;
+82 DO EXIT
+83 QUIT
+84 ;
GETWT(RET,DFN,ADT) ;
+1 ; REQUIRE DFN AND APPOINTMENT DATE TIME
+2 if '$GET(DFN)
QUIT
+3 if '$GET(ADT)
QUIT
+4 ;
+5 ;strip off extra zeros on time pwc SD*5.3*694
SET ADT=+ADT
+6 DO INIT
+7 ;
+8 SET (REQTC,REQT,NATCODE,NAT,AMD,PAM1,CID,FUVCODE,FUV,CWT1,CWT2)=""
+9 ;
+10 ;REQTC=Request Type Code - Patient File Appointment Multiple [0,25]
+11 ;REQT=Request Type
+12 ;NATCODE=Next Available Type Code - Patient File Appointment Multiple [0,26]
+13 ;NAT=Next Available Type
+14 ;AMD=Appointment Made Date - Patient File Appointment Multiple [0,19]
+15 ;PAM1=Global Location 1 of the Patient File Appointment Multiple
+16 ;CID=Clinic Indicated Date/Preferred Date - Patient File Appointment Multiple [1,1]
+17 ;FUVCODE=Follow-Up Visit Code 1=Yes 0=No - Patient File Appointment Multiple [1,2]
+18 ;FUV=Follow-Up Visit
+19 ;CWT1=Clinic Wait Time 1
+20 ;CWT2=Clinic Wait Time 2
+21 ;
+22 ; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 0
+23 IF PAM0'=""
Begin DoDot:1
+24 SET REQTC=$PIECE($GET(PAM0),U,25)
IF REQTC'=""
Begin DoDot:2
+25 IF REQTC="N"
SET REQT="'NEXT AVAILABLE' APPT."
+26 IF REQTC="C"
SET REQT="OTHER THAN 'NEXT AVA.' (CLINICIAN REQ.)"
+27 IF REQTC="P"
SET REQT="OTHER THAN 'NEXT AVA.' (PATIENT REQ.)"
+28 IF REQTC="W"
SET REQT="WALKIN APPT."
+29 IF REQTC="M"
SET REQT="MULTIPLE APPT. BOOKING"
+30 IF REQTC="A"
SET REQT="AUTO REBOOK"
+31 IF REQTC="O"
SET REQT="OTHER THAN 'NEXT AVA.' APPT."
End DoDot:2
+32 SET NATCODE=$PIECE($GET(PAM0),U,26)
IF NATCODE'=""
Begin DoDot:2
+33 IF NATCODE=0
SET NAT="NOT INDICATED TO BE A 'NEXT AVA.' APPT."
+34 IF NATCODE=1
SET NAT="'NEXT AVA.' APPT. INDICATED BY USER"
+35 IF NATCODE=3
SET NAT="'NEXT AVA.' APPT. INDICATED BY CALCULATION"
+36 IF NATCODE=4
SET NAT="'NEXT AVA.' APPT. INDICATED BY USER & CALCULATION"
End DoDot:2
+37 SET AMD=$PIECE($GET(PAM0),U,19)
End DoDot:1
+38 ;
+39 ; -PATIENT/APPOINTMENT MULTIPLE GLOBAL LOCATION 1
+40 SET PAM1=$GET(^DPT(DFN,"S",ADT,1))
IF PAM1'=""
Begin DoDot:1
+41 SET CID=$PIECE($GET(PAM1),U,1)
+42 SET FUVCODE=$PIECE($GET(PAM1),U,2)
+43 SET FUV="No"
IF FUVCODE=1
SET FUV="Yes"
End DoDot:1
+44 ;
+45 ; CALULATE WAIT TIMES
+46 SET (X,X1,X2)=""
+47 IF AMD'=""
Begin DoDot:1
+48 SET X1=ADT
SET X2=AMD
DO ^%DTC
SET CWT1=X
End DoDot:1
+49 IF CID'=""
Begin DoDot:1
+50 SET X1=ADT
SET X2=CID
DO ^%DTC
SET CWT2=X
End DoDot:1
+51 ;
+52 ; -CONVERT DATES TO EXTERNAL
+53 ;
+54 ; Change date/time conversion so midnight is handled properly. wtc 694 5/7/18
+55 ;
+56 ;I CID'="" S Y=CID D D^DIQ S CID=Y
+57 ;
IF CID'=""
SET CID=$$FMTONET^SDECDATE(CID)
+58 ;
+59 SET RET=REQT_U_NAT_U_CID_U_FUV_U_CWT1_U_CWT2
+60 ;
+61 DO EXIT
+62 QUIT
+63 ;
+64 ;STATUS, LAST ADMIT/LODGER DATE, LAST DISCHARGE/LODGER DATE
INP ;
+1 if '$GET(DFN)
QUIT
+2 ;
+3 SET (LADMT,LDIS,DNUM,STAT,SDST,SDSTA,REN,A)=""
+4 IF '$DATA(^DGPM("C",DFN))
SET LSTAT="NO INPT./LOD. ACT."
QUIT
+5 ;
+6 SET VAIP("D")="L"
SET VAIP("L")=""
DO INP^DGPMV10
+7 SET A=$SELECT("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
SET SDST=$SELECT('A:"IN",1:"")_"ACTIVE "
SET SDSTA=$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",1:"INPATIENT")
+8 SET STAT=""
SET STAT=SDST_SDSTA
+9 SET LADMT=""
SET LADMT=$PIECE($GET(DGPMVI(13,1)),"^",2)
+10 SET DNUM=""
SET DNUM=$GET(DGPMV1(17))
IF DNUM'=""
Begin DoDot:1
+11 SET LDIS=""
SET LDIS=$$GET1^DIQ(405,DNUM,.01)
End DoDot:1
+12 QUIT
GETPTIN(RET,DFN,ADT) ;
+1 ;REQUIRE DFN AND APPOINTMENT DATE TIME
+2 if '$GET(DFN)
QUIT
+3 if '$GET(ADT)
QUIT
+4 ;
+5 ;strip off extra zeros on time pwc SD*5.3*694
SET ADT=+ADT
+6 DO INIT
+7 ;
+8 SET (DOB,SSN,SEX,MARSIEN,MARS,RELGP,PAT36,PELIG,POS,SADDR1,SWASIAC)=""
+9 SET (SADDR2,SADDR3,CITY,STATEN,STATE,CNTY,ADDR,PHN,CPHN,PGER,EMAIL,RADEXC)=""
+10 SET (RADEX,STAT,POW,LADMT,AOEXLC,AOEXL,LDIS,CMBTVC,CMBTV,CMBTVED,PROJ112)=""
+11 SET (PROCODE,SWASIA,PAT36,PAT11,PAT13,PAT36,PAT52,PAT321,PAT322,POWCODE)=""
+12 SET (RELGPN,PELIGN,POSN)=""
+13 ;
+14 ;DOB=Date Of Birth - Patient File [0,3]
+15 ;SSN=Formatted Social Security Number
+16 ;SEX=Male or Female - Patient File [0,2]
+17 ;MARSIEN=Marital Status IEN - Patient File [0,5]
+18 ;MARS=Marital Status - Marital Status File (11) Field .01
+19 ;RELGPN=Religious Preference IEN - Patient File [0,8]
+20 ;RELGP=Religious Preference - file 13 field .01 (Name)
+21 ;PELIGN=Primary Eligibility IEN - Patient File [.36,1]
+22 ;PELIG=Primary Eligibility - File 8 field .01 (name)
+23 ;POSN=Period of Service IEN
+24 ;POS=Period of Service - File 21 Field .01 (Name)
+25 ;SADDR1=Street Address 1 - Patient File [.11,1]
+26 ;SADDR2=Street Address 2 - Patient File [.11,2]
+27 ;SADDR3=Street Address 2 - Patient File [.11,3]
+28 ;CITY=City - Patient File [.11,4]
+29 ;STATEN=State IEN - Patient File [.11,5]
+30 ;STATE=State - State File (5) Field .01
+31 ;CNTYIEN=Country IEN - Patient File [.11,10]
+32 ;CNTY=Country - Country Code File (779.004) Field .01
+33 ;ADDR=Address
+34 ;PHN=Phone Number - Patient File [.13,1]
+35 ;CPHN=Cell Phone Number - Patient File [.13,4]
+36 ;PGER=Pager Number - Patient File [.13,5]
+37 ;EMAIL=Email Address - Patient File [.13,3]
+38 ;RADEXC=Radiation Exposure CODE Y=Yes N=No U=Unknown - Patient File [.321,3]
+39 ;RADEX=Radiation Exposure
+40 ;
+41 ;STAT=Status ???
+42 ;
+43 ;POWCODE=Prisoner Of War CODE Y=Yes N=No U=Unknown - Patient File [.52,5]
+44 ;POW=Prisoner Of War
+45 ;
+46 ;LADMT=Last Admit/Lodger Date ???
+47 ;
+48 ;AOEXLC=Agent Orange Exposure Location CODE K=Korean DMZ V=Vietnam O=Other - Patient File [.321,13]
+49 ;AOEXL=Agent Orange Exposure Location
+50 ;
+51 ;LDIS=Last Discharge/Lodger Date ???
+52 ;
+53 ;CMBTVC=Combat Veteran CODE Y=Yes N=No - Patient File [.52,11]
+54 ;CMBTV=Combat Veteran
+55 ;CMBTVED=Combat Veteran End Date - Patient File [.52,14]
+56 ;PROCODE=Project 112/SHAD CODE 0=No 1=Yes - Patient File [.321,15]
+57 ;PROJ112=Project 112/SHAD
+58 ;SWASIAC=SW Asia Conditions Code Y=Yes N=No U=Unknown - Patient File [.322,13]
+59 ;SWASIA=SW Asia Conditions
+60 ;
+61 ; -PATIENT FILE GLOBAL LOCATION 0
+62 IF PAT0'=""
Begin DoDot:1
+63 SET DOB=$PIECE($GET(PAT0),U,3)
+64 SET SSN=$$LAST4SSN^SDESINPUTVALUTL(DFN)
+65 SET SEXCODE=$PIECE($GET(PAT0),U,2)
IF SEXCODE'=""
Begin DoDot:2
+66 IF SEXCODE="M"
SET SEX="Male"
+67 IF SEXCODE="F"
SET SEX="Female"
End DoDot:2
+68 SET MARSIEN=$PIECE($GET(PAT0),U,5)
IF MARSIEN'=""
Begin DoDot:2
+69 SET MARS=$$GET1^DIQ(11,MARSIEN,.01)
End DoDot:2
+70 SET RELGPN=$PIECE($GET(PAT0),U,8)
IF RELGPN'=""
Begin DoDot:2
+71 SET RELGP=$$GET1^DIQ(13,RELGPN,.01)
End DoDot:2
End DoDot:1
+72 ;
+73 ; -PATIENT FILE GLOBAL LOCATION .11
+74 SET PAT11=$GET(^DPT(DFN,.11))
IF PAT11'=""
Begin DoDot:1
+75 SET SADDR1=$PIECE($GET(PAT11),U,1)
+76 SET SADDR2=$PIECE($GET(PAT11),U,2)
+77 SET SADDR3=$PIECE($GET(PAT11),U,3)
+78 SET CITY=$PIECE($GET(PAT11),U,4)
+79 SET STATEN=$PIECE($GET(PAT11),U,5)
IF STATEN'=""
Begin DoDot:2
+80 SET STATE=$$GET1^DIQ(5,STATEN,.01)
End DoDot:2
+81 SET ZCODE=$PIECE($GET(PAT11),U,6)
+82 SET CNTYIEN=$PIECE($GET(PAT11),U,10)
IF CNTYIEN'=""
Begin DoDot:2
+83 SET CNTY=$$GET1^DIQ(779.004,CNTYIEN,.01)
End DoDot:2
+84 SET SADDR=SADDR1
IF SADDR2'=""
Begin DoDot:2
+85 SET SADDR=SADDR1_" "_SADDR2
IF SADDR3'=""
Begin DoDot:3
+86 SET SADDR=SADDR1_" "_SADDR2_" "_SADDR3
End DoDot:3
End DoDot:2
+87 SET ADDR=SADDR_" "_CITY_", "_STATE_" "_ZCODE_" "_CNTY
End DoDot:1
+88 ;
+89 ; -PATIENT FILE GLOBAL LOCATION .13
+90 SET PAT13=$GET(^DPT(DFN,.13))
IF PAT13'=""
Begin DoDot:1
+91 SET PHN=$PIECE($GET(PAT13),U,1)
+92 SET CPHN=$PIECE($GET(PAT13),U,4)
+93 SET PGER=$PIECE($GET(PAT13),U,5)
+94 SET EMAIL=$PIECE($GET(PAT13),U,3)
End DoDot:1
+95 ;
+96 ; -PATIENT FILE GLOBAL LOCATION .36
+97 SET PAT36=$GET(^DPT(DFN,.36))
IF PAT36'=""
Begin DoDot:1
+98 SET PELIGN=$PIECE($GET(PAT36),U,1)
IF PELIGN'=""
Begin DoDot:2
+99 SET PELIG=$$GET1^DIQ(8,PELIGN,.01)
End DoDot:2
End DoDot:1
+100 ;
+101 ; -PATIENT FILE GLOBAL LOCATION .52
+102 SET PAT52=$GET(^DPT(DFN,.52))
IF PAT52'=""
Begin DoDot:1
+103 SET POWCODE=$PIECE($GET(PAT52),U,5)
IF POWCODE'=""
Begin DoDot:2
+104 IF POWCODE="Y"
SET POW="Yes"
+105 IF POWCODE="N"
SET POW="No"
+106 IF POWCODE="U"
SET POW="Unknown"
End DoDot:2
+107 SET CMBTVC=$PIECE($GET(PAT52),U,11)
IF CMBTVC'=""
Begin DoDot:2
+108 SET CMBTV="No"
+109 IF CMBTVC="Y"
SET CMBTV="Yes"
End DoDot:2
+110 SET CMBTVED=$PIECE($GET(PAT52),U,14)
IF CMBTV="No"
Begin DoDot:2
+111 SET CMBTVED="N/A"
End DoDot:2
End DoDot:1
+112 ;
+113 ; -PATIENT FILE GLOBAL LOCATION .321
+114 SET PAT321=$GET(^DPT(DFN,.52))
IF PAT321'=""
Begin DoDot:1
+115 SET RADEXC=$PIECE($GET(PAT321),U,3)
IF RADEXC'=""
Begin DoDot:2
+116 IF RADEXC="Y"
SET RADEX="Yes"
+117 IF RADEXC="N"
SET RADEX="No"
+118 IF RADEXC="U"
SET RADEX="Unknown"
End DoDot:2
+119 SET AOEXLC=$PIECE($GET(PAT321),U,13)
IF AOEXLC'=""
Begin DoDot:2
+120 IF AOEXLC="K"
SET AOEXL="Korean DMZ"
+121 IF AOEXLC="V"
SET AOEXL="Vietnam"
+122 IF AOEXLC="O"
SET AOEXL="Other (Not Korean DMZ or Vietnam)"
End DoDot:2
+123 SET PROCODE=$PIECE($GET(PAT321),U,15)
IF PROCODE'=""
Begin DoDot:2
+124 IF PROCODE=2
SET PROJ112="No"
+125 IF PROCODE=1
SET PROJ112="Yes"
End DoDot:2
End DoDot:1
+126 ;
+127 ; -PATIENT FILE GLOBAL LOCATION .322
+128 SET PAT322=$GET(^DPT(DFN,.52))
IF PAT322'=""
Begin DoDot:1
+129 SET SWASIAC=$PIECE($GET(PAT322),U,13)
IF SWASIAC'=""
Begin DoDot:2
+130 IF SWASIAC="Y"
SET SWASIA="Yes"
+131 IF SWASIAC="N"
SET SWASIA="No"
+132 IF SWASIAC="U"
SET SWASIA="Unknown"
End DoDot:2
End DoDot:1
+133 ;
+134 ; -CONVERT DATES TO EXTERNAL
+135 IF DOB'=""
SET Y=DOB
DO D^DIQ
SET DOB=Y
+136 ;
+137 ; -PERIOD OF SERVICE
+138 SET (POSN,POS)=""
SET POSN=$$GET1^DIQ(2,DFN_",",.323,"I")
IF POSN'=""
SET POS=$$GET1^DIQ(21,POSN,.01,"E")
+139 ;
+140 ; -GET STAT, LADMT, LDIS
+141 DO INP
+142 ;
+143 SET RET=DOB_U_SSN_U_SEX_U_MARS_U_RELGP_U_PELIG_U_POS_U_ADDR_U_PHN_U_CPHN_U_PGER_U_EMAIL_U_RADEX_U_STAT_U_POW_U_LADMT_U_AOEXL_U_LDIS_U_CMBTV_U_CMBTVED_U_PROJ112_U_SWASIA
+144 ;
+145 DO EXIT
+146 QUIT
+147 ;
EXIT ;
+1 KILL PAT0,PAM0,CLIEN,HLF0,HLAPIEN,HLAP0,PAMS,PCODE,ATIEN,CCODE,ECODE,PAMSC
+2 KILL AMUIEN,AMU,HLAPC,CIUIEN,COUIEN,NCUIEN,PAT36,SADDR1,SWASIAC,SADDR2,SADDR3
+3 KILL CITY,STATEN,STATE,CNTY,RADEXC,AOEXLC,CMBTVC,PROCODE,PAT36,PAT11,PAT13,PAT52
+4 KILL PAT321,PAT322,ENROLC
+5 QUIT
