SDEC01C ;ALB/AJF,DJS - VISTA SCHEDULING RPCS ;SEP 12, 2022
;;5.3;Scheduling;**686,825**;;Build 2
;;Per VHA Directive 6402, this routine should not be modified
;
Q
;
RESOURCE(SDECY,SDECDUZ,SDACT,SDTYPE,MAXREC,LASTSUBI,SDIEN,SDECP) ;Returns ADO Recordset with ALL RESOURCE names
; SDECDUZ = (optional) pointer to NEW PERSON file
; Defaults to current user
; checks that overbook is allowed
; SDACT = (optional) 1 or YES will return only active resources
; 0, NO, or null will include inactive
; SDTYPE = (optional) null will return all resource types
; H will only return HOSPITAL LOCATION (clinic) resources
; P will only return NEW PERSON (Provider) resources
; A will only return SDEC ADDITIONAL RESOURCE resources
; PH will only return prohibited clinics
; MAXREC - (optional) Max records returned
; LASTSUBI - (optional) last subscripts from previous call
; SDIEN - (optional) pointer to SDEC RESOURCE file
; only 1 record will be returned if SDIEN is present
; SDECP - (optional) Partial name text
;RETURN:
; Successful Return:
; a global array in which each array entry contains data from the
; SDEC RESOURCE file
; 1. RESOURCEID - Pointer to the SDEC RESOURCE file
; 2. HOSPITALID - Pointer to the HOSPITAL LOCATION file 44
; 3. CLINNAME - Clinic Name from HOSPITAL LOCATION file 44
; 4. ABBR - Abbreviation
; 5. RESOURCE_NAME - NAME from SDEC RESOURCE file
; 6. E-CHECKIN_ALLOWED
; 7. PRE-CHECKIN_ALLOWED
; 8. TIME_ZONE
;
;
N SDA,SDCL,SDDATA,SDMSG,SDECERR,SDECRET,SDECIEN,SDECRES,SDECDEP,SDECDDR,SDECDEPN,SDECRDAT,SDECRNOD,SDECI,SDEC,SDECLTR
N ABBR,SDECNOS,SDECCAN,SDF,SDTYPR,SDX,SDPRO,PRO,SDH,SDK,SDRT,SDT,SDXT,SDCN,SDHL
S (SDF,SDRT,SDT,SDX)="",SDPRO=0
S SDECY="^TMP(""SDEC01C"","_$J_",""RESOURCE"")"
K @SDECY
S SDECI=0
S (SDECERR,SDTYPR)=""
; 1 2 3
S @SDECY@(SDECI)="I00010RESOURCEID^I00010HOSPITAL_LOCATION_ID^T00030CLINNAME^T00030ABBR^T00030RESOURCE_NAME^T00030E-CHECKIN_ALLOWED^T00030PRE-CHECKIN_ALLOWED^T00030TIME_ZONE"_$C(30)
;validate user
S SDECDUZ=$G(SDECDUZ)
I '+SDECDUZ S SDECDUZ=DUZ
;validate active
S SDACT=1
;S SDACT=$G(SDACT)
;S SDACT=$S(SDACT=1:1,SDACT="YES":1,1:0)
;validate type
S SDTYPE="H"
;MGH added new type
;I SDTYPE="PH" S SDPRO=1
S SDTYPE=$S(SDTYPE="H":"SC(",SDTYPE="P":"VA(200",SDTYPE="A":"SDEC",1:"")
;validate MAXREC
S MAXREC=$G(MAXREC,9999999)
;validate LASTSUBI
S LASTSUBI=$G(LASTSUBI)
;validate SDIEN
;MGH changed to allow multiple IENS
S SDIEN=$G(SDIEN)
I SDIEN'="",'$D(^SDEC(409.831,+SDIEN,0)) S SDIEN=""
I $G(SDIEN) D G RESX
.F SDK=1:1:$L(SDIEN,"|") D
..S SDECIEN=$P(SDIEN,"|",SDK)
..Q:'$D(^SDEC(409.831,+SDECIEN,0))
..S SDECRES=SDECIEN
..D RES1
;ien lookup
;I +SDIEN S SDECRES=+SDIEN D RES1 G RESX
;validate SDECP
S SDECP=$G(SDECP)
;partial name lookup
I SDECP'="" D
.S SDF=$S($P(LASTSUBI,"|",1)'="":$P(LASTSUBI,"|",1),1:"")
.S (SDX,SDXT)=$S($P(LASTSUBI,"|",2)'="":$$GETSUB^SDEC56($P(LASTSUBI,"|",2)),1:$$GETSUB^SDEC56(SDECP))
.I ($P(LASTSUBI,"|",1)="")!($P(LASTSUBI,"|",1)="ABBR") S SDF="ABBR" F S SDX=$O(^SDEC(409.831,"C",SDX)) Q:SDX="" Q:SDX'[SDECP D Q:(+MAXREC)&(SDECI'<MAXREC)
..S (SDECRES,SDRT)=$S($P(LASTSUBI,"|",3)'="":$P(LASTSUBI,"|",3),1:0)
..S LASTSUBI="" F S SDECRES=$O(^SDEC(409.831,"C",SDX,SDECRES)) Q:'+SDECRES D RES1 Q:(+MAXREC)&(SDECI'<MAXREC)
.I ($P(LASTSUBI,"|",1)="")!($P(LASTSUBI,"|",1)="FULL") S SDF="FULL",SDX=SDXT F S SDX=$O(^SDEC(409.831,"B",SDX)) Q:SDX="" Q:SDX'[SDECP D Q:(+MAXREC)&(SDECI'<MAXREC)
..S (SDECRES,SDRT)=$S($P(LASTSUBI,"|",3)'="":$P(LASTSUBI,"|",3),SDRT'="":SDRT,1:0)
..S LASTSUBI="" F S SDECRES=$O(^SDEC(409.831,"B",SDX,SDECRES)) Q:'+SDECRES D RES1 Q:(+MAXREC)&(SDECI'<MAXREC)
;$O THRU SDEC RESOURCE File
I SDECP="",'+SDIEN S SDECRES=$S($P(LASTSUBI,"|",2)'="":$P(LASTSUBI,"|",2),1:0) F S SDECRES=$O(^SDEC(409.831,SDECRES)) Q:'+SDECRES D Q:(+MAXREC)&(SDECI'<MAXREC)
.D RES1
RESX ;
S @SDECY@(SDECI)=@SDECY@(SDECI)_$C(31)
Q
RES1 ; get data for 1 resource
N FND
S FND=0
Q:'$D(^SDEC(409.831,SDECRES,0))
I SDF="FULL",SDECP'="" S FND=$$CHK(SDECP,SDECRES) Q:+FND ;alb/sat 658 - stop if 'this' record found in abbreviations
I SDECP'="" S SDH=0 F S SDH=$O(^SDEC(409.831,"C",SDECP,SDH)) Q:SDH="" S FND=SDH=SDECRES Q:FND
S SDECRNOD=^SDEC(409.831,SDECRES,0)
I SDTYPE'="" Q:$P(SDECRNOD,U,11)'[SDTYPE
S SDTYPR=$P(SDECRNOD,U,11)
S $P(SDTYPR,"|",1)=$S($P(SDTYPR,";",2)="SC(":"H",$P(SDTYPR,";",2)="VA(200,":"P",$P(SDTYPR,";",2)="SDEC(409.834,":"A",1:"")
S $P(SDTYPR,"|",2)=$P($P(SDECRNOD,U,11),";",1)
S $P(SDTYPR,"|",3)=$$GET1^DIQ(409.831,SDECRES_",",.012)
I $P(SDTYPR,"|",1)="P" D RESPRV1^SDEC01B($P(SDTYPR,"|",2),$P(SDECRNOD,U,4)) ;do not include provider resource if NEW PERSON is not active
I $P(SDTYPR,"|",1)="H" D CHKC^SDEC01B($P(SDTYPR,"|",2),SDECRES)
I +SDACT,$$GET1^DIQ(409.831,SDECRES_",",.02)="YES" Q ;do not include inactive entries
D GETACC(.SDECACC,SDECDUZ,SDECRES)
K SDECRDAT
;alb/sat 658 - begin mod
;
S $P(SDECRDAT,U,1)=$P(SDECRNOD,U,1)
S $P(SDECRDAT,U,2)=$P(SDECRNOD,U,2)
S $P(SDECRDAT,U,3)=$P(SDECRNOD,U,3)
S $P(SDECRDAT,U,4)=$P(SDECRNOD,U,4)
S SDHL=$P(SDECRNOD,U,4)
S SDCN=$$GET1^DIQ(44,SDHL_",",.01) ;clinic name
;alb/sat 658 - end mod
S SDECRDAT=SDECRES_U_SDECRDAT ;1,2-5
S SDCL=$P(SDECRDAT,U,5)
Q:+$$GET1^DIQ(44,SDCL_",",50.01,"I")=1 ;OOS?
S PRO=0
;MGH code for new type to only contain prohibited clinics
Q:$G(SDCL)=""&(SDPRO=1)
Q:$G(SDCL)&(SDPRO=1)&($$GET1^DIQ(44,SDCL_",",2500)'="YES")
S $P(SDECRDAT,U,3)=$$GET1^DIQ(409.831,SDECRES_",",.02)
;Get letter text from wp field
S SDECLTR=""
I 0,$D(^SDEC(409.831,SDECRES,1)) D
. S SDECIEN=0
. F S SDECIEN=$O(^SDEC(409.831,SDECRES,1,SDECIEN)) Q:'+SDECIEN D
. . S SDECLTR=SDECLTR_$G(^SDEC(409.831,SDECRES,1,SDECIEN,0))
. . S SDECLTR=SDECLTR_$C(13)_$C(10)
S SDECNOS=""
I 0,$D(^SDEC(409.831,SDECRES,12)) D
. S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.831,SDECRES,12,SDECIEN)) Q:'+SDECIEN D
. . S SDECNOS=SDECNOS_$G(^SDEC(409.831,SDECRES,12,SDECIEN,0))
. . S SDECNOS=SDECNOS_$C(13)_$C(10)
S SDECCAN=""
I 0,$D(^SDEC(409.831,SDECRES,13)) D
. S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.831,SDECRES,13,SDECIEN)) Q:'+SDECIEN D
. . S SDECCAN=SDECCAN_$G(^SDEC(409.831,SDECRES,13,SDECIEN,0))
. . S SDECCAN=SDECCAN_$C(13)_$C(10)
N SDECACC,SDECMGR
S SDECACC="0^0^0^0"
S SDECMGR=$O(^DIC(19.1,"B","SDECZMGR",0))
I +SDECMGR,$D(^VA(200,SDECDUZ,51,SDECMGR)) S SDECACC="1^1^1^1"
I SDECACC="0^0^0^0" D
. N SDECNOD,SDECRUID
. S SDECRUID=0
. ;Get entry for this user and resource
. F S SDECRUID=$O(^SDEC(409.833,"AC",SDECDUZ,SDECRUID)) Q:'+SDECRUID I $D(^SDEC(409.833,SDECRUID,0)),$P(^(0),U)=SDECRES Q
. Q:'+SDECRUID
. S $P(SDECACC,U)=1
. S SDECNOD=$G(^SDEC(409.833,SDECRUID,0))
. S $P(SDECACC,U,2)=+$P(SDECNOD,U,3)
. S $P(SDECACC,U,3)=+$P(SDECNOD,U,4)
. S $P(SDECACC,U,4)=+$P(SDECNOD,U,5)
; 6 7 8 9-12
K SDDATA D GETS^DIQ(409.831,SDECRES_",",".01:.04","IE","SDDATA","SDMSG")
S SDA="SDDATA(409.831,"""_SDECRES_","")"
S ABBR=@SDA@(.011,"E") ;abbreviation
;AJF ; 022718 ; Only return 7 variables
S SDECRDAT=SDECRES_U_SDHL_U_SDCN_U_ABBR_U_$P(SDECRNOD,U)
;S SDECRDAT=SDECRES_U_SDHL_U_SDCN
S $P(SDECRDAT,U,4)=@SDA@(.011,"E") ;abbreviation
S $P(SDECRDAT,U,5)=$S(($G(SDF)="ABBR")&(@SDA@(.011,"E")'=""):@SDA@(.011,"E")_" ",1:"")_$P(SDECRDAT,U,5) ;alb/sat 658 - include abbr in name if found by C xref
;S $P(SDECRDAT,U,6)=SDF_"|"_SDX_"|"_SDECRES ;LASTSUB
;
;DJS ; VSE-3428 ADD E-CHECKIN ALLOWED, PRE-CHECKIN ALLOWED & TIME ZONE
;
N SDECHIN,SDPRECHIN,SDTMZN
D ADDFLDS
S SDECRDAT=SDECRDAT_U_SDECHIN_U_SDPRECHIN_U_SDTMZN
S SDECI=SDECI+1
S @SDECY@(SDECI)=SDECRDAT_$C(30)
Q
;
GETACC(SDECACC,SDECDUZ,SDECRES) ;get view, overbook, modify appt, and modify schedule abilities
;INPUT:
; SDECDUZ = user ID pointer to NEW PERSON file
; SDECRES = resource ID pointer to SDEC RESOURCE file
;RETURN:
; .SDECACC = access separated by ^:
; 1. VIEW - User can VIEW 1=YES; 0=NO
; 2. OVERBOOK - User can OVERBOOK 1=YES; 0=NO
; 3. MODIFY SCHEDULE - User can Modify Schedule 1=YES; 0=NO
; 4. MODIFY APPOINTMENTS User can modify appointments 1=YES; 0=NO
N SDECMGR
S SDECACC="0^0^0^0"
S SDECMGR=$O(^DIC(19.1,"B","SDECZMGR",0))
I +SDECMGR,$D(^VA(200,SDECDUZ,51,SDECMGR)) S SDECACC="1^1^1^1"
I SDECACC="0^0^0^0" D
. N SDECNOD,SDECRUID
. S SDECRUID=0
. ;Get entry for this user and resource
. F S SDECRUID=$O(^SDEC(409.833,"AC",SDECDUZ,SDECRUID)) Q:'+SDECRUID I $D(^SDEC(409.833,SDECRUID,0)),$P(^(0),U)=SDECRES Q
. Q:'+SDECRUID
. S $P(SDECACC,U)=1
. S SDECNOD=$G(^SDEC(409.833,SDECRUID,0))
. S $P(SDECACC,U,2)=+$P(SDECNOD,U,3)
. S $P(SDECACC,U,3)=+$P(SDECNOD,U,4)
. S $P(SDECACC,U,4)=+$P(SDECNOD,U,5)
Q
;
GETLTRS(SDECLTR,SDECNOS,SDECCAN,SDECRES,SDCL) ;get resource letters
;INPUT:
; SDECRES = resource ID pointer to SDEC RESOURCE file
; SDCL = clinic ID pointer to HOSPITAL LOCATION file
;RETURN:
; .SDECLTR = LETTER TEXT
; .SDECNOS = NO SHOW LETTER
; .SDECCAN = CLINIC CANCELLATION LETTER
; .Get letter text from wp field
N SDECIEN
S SDECLTR=""
I $D(^SDEC(409.831,SDECRES,2,SDCL,1)) D
. S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.831,SDECRES,2,SDCL,1,SDECIEN)) Q:'+SDECIEN D
. . S SDECLTR=SDECLTR_$G(^SDEC(409.831,SDECRES,2,SDCL,1,SDECIEN,0))
. . S SDECLTR=SDECLTR_$C(13)_$C(10)
S SDECNOS=""
I $D(^SDEC(409.831,SDECRES,2,SDCL,12)) D
. S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.831,SDECRES,2,SDCL,12,SDECIEN)) Q:'+SDECIEN D
. . S SDECNOS=SDECNOS_$G(^SDEC(409.831,SDECRES,2,SDCL,12,SDECIEN,0))
. . S SDECNOS=SDECNOS_$C(13)_$C(10)
S SDECCAN=""
I $D(^SDEC(409.831,SDECRES,13)) D
. S SDECIEN=0 F S SDECIEN=$O(^SDEC(409.831,SDECRES,2,SDCL,13,SDECIEN)) Q:'+SDECIEN D
. . S SDECCAN=SDECCAN_$G(^SDEC(409.831,SDECRES,2,SDCL,13,SDECIEN,0))
. . S SDECCAN=SDECCAN_$C(13)_$C(10)
Q
;
CHK(SDECP,SDECRES) ;alb/sat 658 - stop if 'this' record found in abbreviations
N FND,SDR,SDX
S FND=0
S SDX=$$GETSUB^SDEC56(SDECP)
F S SDX=$O(^SDEC(409.831,"C",SDX)) Q:SDX="" Q:SDX'[SDECP D Q:+FND
.S SDR=0 F S SDR=$O(^SDEC(409.831,"C",SDX,SDR)) Q:'+SDR S FND=SDR=SDECRES Q:+FND
Q FND
;
ADDFLDS ; ADD E-CHECKIN ALLOWED, PRE-CHECKIN ALLOWED AND TIME ZONE TO OUTPUT
S SDECHIN=$$GET1^DIQ(44,SDCL_",",20,"I")
S SDPRECHIN=$$GET1^DIQ(44,SDCL_",",21,"I")
S SDTMZN=$$TIMEZONEDATA^SDESUTIL($G(SDCL)),SDTMZN=$P($G(SDTMZN),U)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC01C 10790 printed Dec 13, 2024@02:49:51 Page 2
SDEC01C ;ALB/AJF,DJS - VISTA SCHEDULING RPCS ;SEP 12, 2022
+1 ;;5.3;Scheduling;**686,825**;;Build 2
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 QUIT
+5 ;
RESOURCE(SDECY,SDECDUZ,SDACT,SDTYPE,MAXREC,LASTSUBI,SDIEN,SDECP) ;Returns ADO Recordset with ALL RESOURCE names
+1 ; SDECDUZ = (optional) pointer to NEW PERSON file
+2 ; Defaults to current user
+3 ; checks that overbook is allowed
+4 ; SDACT = (optional) 1 or YES will return only active resources
+5 ; 0, NO, or null will include inactive
+6 ; SDTYPE = (optional) null will return all resource types
+7 ; H will only return HOSPITAL LOCATION (clinic) resources
+8 ; P will only return NEW PERSON (Provider) resources
+9 ; A will only return SDEC ADDITIONAL RESOURCE resources
+10 ; PH will only return prohibited clinics
+11 ; MAXREC - (optional) Max records returned
+12 ; LASTSUBI - (optional) last subscripts from previous call
+13 ; SDIEN - (optional) pointer to SDEC RESOURCE file
+14 ; only 1 record will be returned if SDIEN is present
+15 ; SDECP - (optional) Partial name text
+16 ;RETURN:
+17 ; Successful Return:
+18 ; a global array in which each array entry contains data from the
+19 ; SDEC RESOURCE file
+20 ; 1. RESOURCEID - Pointer to the SDEC RESOURCE file
+21 ; 2. HOSPITALID - Pointer to the HOSPITAL LOCATION file 44
+22 ; 3. CLINNAME - Clinic Name from HOSPITAL LOCATION file 44
+23 ; 4. ABBR - Abbreviation
+24 ; 5. RESOURCE_NAME - NAME from SDEC RESOURCE file
+25 ; 6. E-CHECKIN_ALLOWED
+26 ; 7. PRE-CHECKIN_ALLOWED
+27 ; 8. TIME_ZONE
+28 ;
+29 ;
+30 NEW SDA,SDCL,SDDATA,SDMSG,SDECERR,SDECRET,SDECIEN,SDECRES,SDECDEP,SDECDDR,SDECDEPN,SDECRDAT,SDECRNOD,SDECI,SDEC,SDECLTR
+31 NEW ABBR,SDECNOS,SDECCAN,SDF,SDTYPR,SDX,SDPRO,PRO,SDH,SDK,SDRT,SDT,SDXT,SDCN,SDHL
+32 SET (SDF,SDRT,SDT,SDX)=""
SET SDPRO=0
+33 SET SDECY="^TMP(""SDEC01C"","_$JOB_",""RESOURCE"")"
+34 KILL @SDECY
+35 SET SDECI=0
+36 SET (SDECERR,SDTYPR)=""
+37 ; 1 2 3
+38 SET @SDECY@(SDECI)="I00010RESOURCEID^I00010HOSPITAL_LOCATION_ID^T00030CLINNAME^T00030ABBR^T00030RESOURCE_NAME^T00030E-CHECKIN_ALLOWED^T00030PRE-CHECKIN_ALLOWED^T00030TIME_ZONE"_$CHAR(30)
+39 ;validate user
+40 SET SDECDUZ=$GET(SDECDUZ)
+41 IF '+SDECDUZ
SET SDECDUZ=DUZ
+42 ;validate active
+43 SET SDACT=1
+44 ;S SDACT=$G(SDACT)
+45 ;S SDACT=$S(SDACT=1:1,SDACT="YES":1,1:0)
+46 ;validate type
+47 SET SDTYPE="H"
+48 ;MGH added new type
+49 ;I SDTYPE="PH" S SDPRO=1
+50 SET SDTYPE=$SELECT(SDTYPE="H":"SC(",SDTYPE="P":"VA(200",SDTYPE="A":"SDEC",1:"")
+51 ;validate MAXREC
+52 SET MAXREC=$GET(MAXREC,9999999)
+53 ;validate LASTSUBI
+54 SET LASTSUBI=$GET(LASTSUBI)
+55 ;validate SDIEN
+56 ;MGH changed to allow multiple IENS
+57 SET SDIEN=$GET(SDIEN)
+58 IF SDIEN'=""
IF '$DATA(^SDEC(409.831,+SDIEN,0))
SET SDIEN=""
+59 IF $GET(SDIEN)
Begin DoDot:1
+60 FOR SDK=1:1:$LENGTH(SDIEN,"|")
Begin DoDot:2
+61 SET SDECIEN=$PIECE(SDIEN,"|",SDK)
+62 if '$DATA(^SDEC(409.831,+SDECIEN,0))
QUIT
+63 SET SDECRES=SDECIEN
+64 DO RES1
End DoDot:2
End DoDot:1
GOTO RESX
+65 ;ien lookup
+66 ;I +SDIEN S SDECRES=+SDIEN D RES1 G RESX
+67 ;validate SDECP
+68 SET SDECP=$GET(SDECP)
+69 ;partial name lookup
+70 IF SDECP'=""
Begin DoDot:1
+71 SET SDF=$SELECT($PIECE(LASTSUBI,"|",1)'="":$PIECE(LASTSUBI,"|",1),1:"")
+72 SET (SDX,SDXT)=$SELECT($PIECE(LASTSUBI,"|",2)'="":$$GETSUB^SDEC56($PIECE(LASTSUBI,"|",2)),1:$$GETSUB^SDEC56(SDECP))
+73 IF ($PIECE(LASTSUBI,"|",1)="")!($PIECE(LASTSUBI,"|",1)="ABBR")
SET SDF="ABBR"
FOR
SET SDX=$ORDER(^SDEC(409.831,"C",SDX))
if SDX=""
QUIT
if SDX'[SDECP
QUIT
Begin DoDot:2
+74 SET (SDECRES,SDRT)=$SELECT($PIECE(LASTSUBI,"|",3)'="":$PIECE(LASTSUBI,"|",3),1:0)
+75 SET LASTSUBI=""
FOR
SET SDECRES=$ORDER(^SDEC(409.831,"C",SDX,SDECRES))
if '+SDECRES
QUIT
DO RES1
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
End DoDot:2
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
+76 IF ($PIECE(LASTSUBI,"|",1)="")!($PIECE(LASTSUBI,"|",1)="FULL")
SET SDF="FULL"
SET SDX=SDXT
FOR
SET SDX=$ORDER(^SDEC(409.831,"B",SDX))
if SDX=""
QUIT
if SDX'[SDECP
QUIT
Begin DoDot:2
+77 SET (SDECRES,SDRT)=$SELECT($PIECE(LASTSUBI,"|",3)'="":$PIECE(LASTSUBI,"|",3),SDRT'="":SDRT,1:0)
+78 SET LASTSUBI=""
FOR
SET SDECRES=$ORDER(^SDEC(409.831,"B",SDX,SDECRES))
if '+SDECRES
QUIT
DO RES1
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
End DoDot:2
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
End DoDot:1
+79 ;$O THRU SDEC RESOURCE File
+80 IF SDECP=""
IF '+SDIEN
SET SDECRES=$SELECT($PIECE(LASTSUBI,"|",2)'="":$PIECE(LASTSUBI,"|",2),1:0)
FOR
SET SDECRES=$ORDER(^SDEC(409.831,SDECRES))
if '+SDECRES
QUIT
Begin DoDot:1
+81 DO RES1
End DoDot:1
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
RESX ;
+1 SET @SDECY@(SDECI)=@SDECY@(SDECI)_$CHAR(31)
+2 QUIT
RES1 ; get data for 1 resource
+1 NEW FND
+2 SET FND=0
+3 if '$DATA(^SDEC(409.831,SDECRES,0))
QUIT
+4 ;alb/sat 658 - stop if 'this' record found in abbreviations
IF SDF="FULL"
IF SDECP'=""
SET FND=$$CHK(SDECP,SDECRES)
if +FND
QUIT
+5 IF SDECP'=""
SET SDH=0
FOR
SET SDH=$ORDER(^SDEC(409.831,"C",SDECP,SDH))
if SDH=""
QUIT
SET FND=SDH=SDECRES
if FND
QUIT
+6 SET SDECRNOD=^SDEC(409.831,SDECRES,0)
+7 IF SDTYPE'=""
if $PIECE(SDECRNOD,U,11)'[SDTYPE
QUIT
+8 SET SDTYPR=$PIECE(SDECRNOD,U,11)
+9 SET $PIECE(SDTYPR,"|",1)=$SELECT($PIECE(SDTYPR,";",2)="SC(":"H",$PIECE(SDTYPR,";",2)="VA(200,":"P",$PIECE(SDTYPR,";",2)="SDEC(409.834,":"A",1:"")
+10 SET $PIECE(SDTYPR,"|",2)=$PIECE($PIECE(SDECRNOD,U,11),";",1)
+11 SET $PIECE(SDTYPR,"|",3)=$$GET1^DIQ(409.831,SDECRES_",",.012)
+12 ;do not include provider resource if NEW PERSON is not active
IF $PIECE(SDTYPR,"|",1)="P"
DO RESPRV1^SDEC01B($PIECE(SDTYPR,"|",2),$PIECE(SDECRNOD,U,4))
+13 IF $PIECE(SDTYPR,"|",1)="H"
DO CHKC^SDEC01B($PIECE(SDTYPR,"|",2),SDECRES)
+14 ;do not include inactive entries
IF +SDACT
IF $$GET1^DIQ(409.831,SDECRES_",",.02)="YES"
QUIT
+15 DO GETACC(.SDECACC,SDECDUZ,SDECRES)
+16 KILL SDECRDAT
+17 ;alb/sat 658 - begin mod
+18 ;
+19 SET $PIECE(SDECRDAT,U,1)=$PIECE(SDECRNOD,U,1)
+20 SET $PIECE(SDECRDAT,U,2)=$PIECE(SDECRNOD,U,2)
+21 SET $PIECE(SDECRDAT,U,3)=$PIECE(SDECRNOD,U,3)
+22 SET $PIECE(SDECRDAT,U,4)=$PIECE(SDECRNOD,U,4)
+23 SET SDHL=$PIECE(SDECRNOD,U,4)
+24 ;clinic name
SET SDCN=$$GET1^DIQ(44,SDHL_",",.01)
+25 ;alb/sat 658 - end mod
+26 ;1,2-5
SET SDECRDAT=SDECRES_U_SDECRDAT
+27 SET SDCL=$PIECE(SDECRDAT,U,5)
+28 ;OOS?
if +$$GET1^DIQ(44,SDCL_",",50.01,"I")=1
QUIT
+29 SET PRO=0
+30 ;MGH code for new type to only contain prohibited clinics
+31 if $GET(SDCL)=""&(SDPRO=1)
QUIT
+32 if $GET(SDCL)&(SDPRO=1)&($$GET1^DIQ(44,SDCL_",",2500)'="YES")
QUIT
+33 SET $PIECE(SDECRDAT,U,3)=$$GET1^DIQ(409.831,SDECRES_",",.02)
+34 ;Get letter text from wp field
+35 SET SDECLTR=""
+36 IF 0
IF $DATA(^SDEC(409.831,SDECRES,1))
Begin DoDot:1
+37 SET SDECIEN=0
+38 FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,1,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+39 SET SDECLTR=SDECLTR_$GET(^SDEC(409.831,SDECRES,1,SDECIEN,0))
+40 SET SDECLTR=SDECLTR_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+41 SET SDECNOS=""
+42 IF 0
IF $DATA(^SDEC(409.831,SDECRES,12))
Begin DoDot:1
+43 SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,12,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+44 SET SDECNOS=SDECNOS_$GET(^SDEC(409.831,SDECRES,12,SDECIEN,0))
+45 SET SDECNOS=SDECNOS_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+46 SET SDECCAN=""
+47 IF 0
IF $DATA(^SDEC(409.831,SDECRES,13))
Begin DoDot:1
+48 SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,13,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+49 SET SDECCAN=SDECCAN_$GET(^SDEC(409.831,SDECRES,13,SDECIEN,0))
+50 SET SDECCAN=SDECCAN_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+51 NEW SDECACC,SDECMGR
+52 SET SDECACC="0^0^0^0"
+53 SET SDECMGR=$ORDER(^DIC(19.1,"B","SDECZMGR",0))
+54 IF +SDECMGR
IF $DATA(^VA(200,SDECDUZ,51,SDECMGR))
SET SDECACC="1^1^1^1"
+55 IF SDECACC="0^0^0^0"
Begin DoDot:1
+56 NEW SDECNOD,SDECRUID
+57 SET SDECRUID=0
+58 ;Get entry for this user and resource
+59 FOR
SET SDECRUID=$ORDER(^SDEC(409.833,"AC",SDECDUZ,SDECRUID))
if '+SDECRUID
QUIT
IF $DATA(^SDEC(409.833,SDECRUID,0))
IF $PIECE(^(0),U)=SDECRES
QUIT
+60 if '+SDECRUID
QUIT
+61 SET $PIECE(SDECACC,U)=1
+62 SET SDECNOD=$GET(^SDEC(409.833,SDECRUID,0))
+63 SET $PIECE(SDECACC,U,2)=+$PIECE(SDECNOD,U,3)
+64 SET $PIECE(SDECACC,U,3)=+$PIECE(SDECNOD,U,4)
+65 SET $PIECE(SDECACC,U,4)=+$PIECE(SDECNOD,U,5)
End DoDot:1
+66 ; 6 7 8 9-12
+67 KILL SDDATA
DO GETS^DIQ(409.831,SDECRES_",",".01:.04","IE","SDDATA","SDMSG")
+68 SET SDA="SDDATA(409.831,"""_SDECRES_","")"
+69 ;abbreviation
SET ABBR=@SDA@(.011,"E")
+70 ;AJF ; 022718 ; Only return 7 variables
+71 SET SDECRDAT=SDECRES_U_SDHL_U_SDCN_U_ABBR_U_$PIECE(SDECRNOD,U)
+72 ;S SDECRDAT=SDECRES_U_SDHL_U_SDCN
+73 ;abbreviation
SET $PIECE(SDECRDAT,U,4)=@SDA@(.011,"E")
+74 ;alb/sat 658 - include abbr in name if found by C xref
SET $PIECE(SDECRDAT,U,5)=$SELECT(($GET(SDF)="ABBR")&(@SDA@(.011,"E")'=""):@SDA@(.011,"E")_" ",1:"")_$PIECE(SDECRDAT,U,5)
+75 ;S $P(SDECRDAT,U,6)=SDF_"|"_SDX_"|"_SDECRES ;LASTSUB
+76 ;
+77 ;DJS ; VSE-3428 ADD E-CHECKIN ALLOWED, PRE-CHECKIN ALLOWED & TIME ZONE
+78 ;
+79 NEW SDECHIN,SDPRECHIN,SDTMZN
+80 DO ADDFLDS
+81 SET SDECRDAT=SDECRDAT_U_SDECHIN_U_SDPRECHIN_U_SDTMZN
+82 SET SDECI=SDECI+1
+83 SET @SDECY@(SDECI)=SDECRDAT_$CHAR(30)
+84 QUIT
+85 ;
GETACC(SDECACC,SDECDUZ,SDECRES) ;get view, overbook, modify appt, and modify schedule abilities
+1 ;INPUT:
+2 ; SDECDUZ = user ID pointer to NEW PERSON file
+3 ; SDECRES = resource ID pointer to SDEC RESOURCE file
+4 ;RETURN:
+5 ; .SDECACC = access separated by ^:
+6 ; 1. VIEW - User can VIEW 1=YES; 0=NO
+7 ; 2. OVERBOOK - User can OVERBOOK 1=YES; 0=NO
+8 ; 3. MODIFY SCHEDULE - User can Modify Schedule 1=YES; 0=NO
+9 ; 4. MODIFY APPOINTMENTS User can modify appointments 1=YES; 0=NO
+10 NEW SDECMGR
+11 SET SDECACC="0^0^0^0"
+12 SET SDECMGR=$ORDER(^DIC(19.1,"B","SDECZMGR",0))
+13 IF +SDECMGR
IF $DATA(^VA(200,SDECDUZ,51,SDECMGR))
SET SDECACC="1^1^1^1"
+14 IF SDECACC="0^0^0^0"
Begin DoDot:1
+15 NEW SDECNOD,SDECRUID
+16 SET SDECRUID=0
+17 ;Get entry for this user and resource
+18 FOR
SET SDECRUID=$ORDER(^SDEC(409.833,"AC",SDECDUZ,SDECRUID))
if '+SDECRUID
QUIT
IF $DATA(^SDEC(409.833,SDECRUID,0))
IF $PIECE(^(0),U)=SDECRES
QUIT
+19 if '+SDECRUID
QUIT
+20 SET $PIECE(SDECACC,U)=1
+21 SET SDECNOD=$GET(^SDEC(409.833,SDECRUID,0))
+22 SET $PIECE(SDECACC,U,2)=+$PIECE(SDECNOD,U,3)
+23 SET $PIECE(SDECACC,U,3)=+$PIECE(SDECNOD,U,4)
+24 SET $PIECE(SDECACC,U,4)=+$PIECE(SDECNOD,U,5)
End DoDot:1
+25 QUIT
+26 ;
GETLTRS(SDECLTR,SDECNOS,SDECCAN,SDECRES,SDCL) ;get resource letters
+1 ;INPUT:
+2 ; SDECRES = resource ID pointer to SDEC RESOURCE file
+3 ; SDCL = clinic ID pointer to HOSPITAL LOCATION file
+4 ;RETURN:
+5 ; .SDECLTR = LETTER TEXT
+6 ; .SDECNOS = NO SHOW LETTER
+7 ; .SDECCAN = CLINIC CANCELLATION LETTER
+8 ; .Get letter text from wp field
+9 NEW SDECIEN
+10 SET SDECLTR=""
+11 IF $DATA(^SDEC(409.831,SDECRES,2,SDCL,1))
Begin DoDot:1
+12 SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,2,SDCL,1,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+13 SET SDECLTR=SDECLTR_$GET(^SDEC(409.831,SDECRES,2,SDCL,1,SDECIEN,0))
+14 SET SDECLTR=SDECLTR_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+15 SET SDECNOS=""
+16 IF $DATA(^SDEC(409.831,SDECRES,2,SDCL,12))
Begin DoDot:1
+17 SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,2,SDCL,12,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+18 SET SDECNOS=SDECNOS_$GET(^SDEC(409.831,SDECRES,2,SDCL,12,SDECIEN,0))
+19 SET SDECNOS=SDECNOS_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+20 SET SDECCAN=""
+21 IF $DATA(^SDEC(409.831,SDECRES,13))
Begin DoDot:1
+22 SET SDECIEN=0
FOR
SET SDECIEN=$ORDER(^SDEC(409.831,SDECRES,2,SDCL,13,SDECIEN))
if '+SDECIEN
QUIT
Begin DoDot:2
+23 SET SDECCAN=SDECCAN_$GET(^SDEC(409.831,SDECRES,2,SDCL,13,SDECIEN,0))
+24 SET SDECCAN=SDECCAN_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
CHK(SDECP,SDECRES) ;alb/sat 658 - stop if 'this' record found in abbreviations
+1 NEW FND,SDR,SDX
+2 SET FND=0
+3 SET SDX=$$GETSUB^SDEC56(SDECP)
+4 FOR
SET SDX=$ORDER(^SDEC(409.831,"C",SDX))
if SDX=""
QUIT
if SDX'[SDECP
QUIT
Begin DoDot:1
+5 SET SDR=0
FOR
SET SDR=$ORDER(^SDEC(409.831,"C",SDX,SDR))
if '+SDR
QUIT
SET FND=SDR=SDECRES
if +FND
QUIT
End DoDot:1
if +FND
QUIT
+6 QUIT FND
+7 ;
ADDFLDS ; ADD E-CHECKIN ALLOWED, PRE-CHECKIN ALLOWED AND TIME ZONE TO OUTPUT
+1 SET SDECHIN=$$GET1^DIQ(44,SDCL_",",20,"I")
+2 SET SDPRECHIN=$$GET1^DIQ(44,SDCL_",",21,"I")
+3 SET SDTMZN=$$TIMEZONEDATA^SDESUTIL($GET(SDCL))
SET SDTMZN=$PIECE($GET(SDTMZN),U)
+4 QUIT
