- 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 Feb 19, 2025@00:16:17 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