SDEC45 ;ALB/SAT,JAS - VISTA SCHEDULING UTILITY RPCS TO RETURN VARIOUS CLINIC AND USER DATA ;May 8, 2023
;;5.3;Scheduling;**627,642,658,756,845**;Aug 13, 1993;Build 8
;;Per VHA Directive 6402, this routine should not be modified
;
; ICR
; ---
; ACCESS TO HOLIDAY FILE SUPPORTED BY ICR 10
; ACCESS TO FILE #200 New Person SUPPORTED BY ICR 10060
;
Q
;
CLINSTOP(SDECY,SDP) ;CLINIC STOP remote procedure ;alb/sat 658 - add SDP for Partial Name input
;return entries from the CLINIC STOP file (#40.7)
N SDECC,SDECI,SDECNOD,SDIEN
;
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020CLINIC_STOP_IEN^T00020CODE^T00020NAME"_$C(30)
S SDP=$G(SDP) ;alb/sat 658
S SDECN=$S(SDP'="":$$GETSUB^SDECU(SDP),1:"") ;alb/sat 658 - set SDECN to partial name
F S SDECN=$O(^DIC(40.7,"B",SDECN)) Q:SDECN="" Q:(SDP'="")&(SDECN'[SDP) D ;alb/sat 658 - check if within partial name bounds
.S SDECC="" F S SDECC=$O(^DIC(40.7,"B",SDECN,SDECC)) Q:SDECC="" D
..S SDECNOD=^DIC(40.7,SDECC,0)
..I $P(SDECNOD,U,3)'="",$P($P(SDECNOD,U,3),".",1)'>$P($$NOW^XLFDT,".",1) Q
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECC_U_$P(SDECNOD,U,2)_U_$P(SDECNOD,U,1)_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
CANREAS(SDECY,SDECIN) ;return active/inactive entries from the CANCELLATION REASONS file 409.2
;CANREAS(SDECY,SDECIN) external parameter tag is in SDEC
; INPUT: SDECIN - (optional) Flag: show inactive 0=active only (default); 1=show active and inactive
N SDECC,SDECI,SDECNOD,SDTYPE
;
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020CANCELLATION_REASONS_IEN^T00020NAME^T00030TYPE^T00030SYSTEM_USE_ONLY"_$C(30)
S:($G(SDECIN)="")!("01"'[$G(SDECIN)) SDECIN=0 ;default to active only
S SDECN=""
F S SDECN=$O(^SD(409.2,"B",SDECN)) Q:SDECN="" D
. S SDECC=$O(^SD(409.2,"B",SDECN,""))
. S SDECNOD=^SD(409.2,SDECC,0)
. I SDECIN!($P($G(SDECNOD),U,4)'=1) D
. . S SDTYPE=$S($P(SDECNOD,U,2)="P":"PATIENT",$P(SDECNOD,U,2)="C":"CLINIC",$P(SDECNOD,U,2)="B":"BOTH",1:"")
. . S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECC_U_$P(SDECNOD,U,1)_U_SDTYPE_U_$S($P(SDECNOD,U,6)=1:"YES",1:"NO")_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
CANCMT(SDECY,TYPE) ;return entries from the SDEC CANCELLATION COMMENT file (#409.88)
;
; SDEC CNCMT RPC - SD*5.3*756 wtc 6/8/2020
;
; TYPE = "NATIONAL" or "LOCAL" [REQUIRED]
;
; Returns list of canned comment hashtags, type and text equivalent or -1^error text
;
N SDIEN,SDECI,SDECTAG ;
;
K ^TMP("SDEC",$J) S SDECY="^TMP(""SDEC"","_$J_")" ;
S SDECI=0,^TMP("SDEC",$J,0)="T00020CANCELLATION_COMMENT_HASHTAG^T00020TYPE^T00080CANCELLATION_COMMENT_TEXT"_$C(30) ;
;
I $G(TYPE)="" D ERR("-1^Missing type") Q ;
I TYPE'="NATIONAL",TYPE'="LOCAL" D ERR("-1^Invalid type") Q ;
;
; Scan SDEC CANCELLATION COMMENT file (#409.88) in hash tag (field #.01) order and load in output array.
;
S SDECI=0,SDECTAG="" ;
F S SDECTAG=$O(^SDEC(409.88,"B",SDECTAG)) Q:SDECTAG="" S SDIEN=0 F S SDIEN=$O(^SDEC(409.88,"B",SDECTAG,SDIEN)) Q:'SDIEN D ;
. I TYPE="NATIONAL" Q:$P(^SDEC(409.88,SDIEN,0),U,3)'=1 ;
. I TYPE="LOCAL" Q:$P(^SDEC(409.88,SDIEN,0),U,3)=1 ;
. ;
. S SDECI=SDECI+1,^TMP("SDEC",$J,SDECI)=SDECTAG_U_TYPE_U_$P(^SDEC(409.88,SDIEN,0),U,2)_$C(30) ;
;
S ^(SDECI)=^TMP("SDEC",$J,SDECI)_$C(31) ;
Q
;
CANCMOPT ;
;
; Create/edit local SDEC CANCELLATION COMMENT option - wtc 756 6/23/2020
;
N DIC,Y,DIE,DA,DR ;
S DIC=409.88,DIC(0)="AEL",DIC("S")="I $P(^(0),U,3)'=1" D ^DIC Q:Y<0 ;
S DIE="^SDEC(409.88,",DA=+Y,DR=".01;1;2///0" D ^DIE ;
Q ;
;
NEWPERS(SDECY,SDCLASS,SDPART,MAXREC,LSUB,INACT) ;return entries from the USR CLASS MEMBERSHIP file that have the 'PROVIDER' USR CLASS
;NEWPERS(SDECY,SDCLASS) external parameter tag is in SDEC
; INPUT:
; SDCLASS - (not used) usr class ID pointer to USR CLASS file 8930
; default is the 'PROVIDER' USR CLASS
; SDPART - (optional) Partial user name
; MAXREC - (optional) Max records returned
; LSUB - (optional) Last subscripts from previous call
; INACT - (optional) inactive flag
; 0=return only active users that do not have an active PERSON CLASS
; 1=return active AND inactive users
N SDECI,SDECN,SDIEN,SDINACT
N SDACT
S INACT=$G(INACT)
S SDECI=0
S SDECY="^TMP(""SDEC"","_$J_")"
K @SDECY
S @SDECY@(SDECI)="T00020NEW_PERSON_IEN^T00020NAME^T00030LASTSUB^T00030INACTIVE"_$C(30)
S SDPART=$G(SDPART)
S MAXREC=$G(MAXREC)
S LSUB=$G(LSUB)
D NP2
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
NP2 ;partial name lookup
N SDCLS,SDECC,SDECN,SDECNPS,SDTMP
S SDECN=$S($P(LSUB,"|",1)'="":$$GETSUB^SDECU($P(LSUB,"|",1)),SDPART'="":$$GETSUB^SDECU(SDPART),1:"")
F S SDECN=$O(^VA(200,"B",SDECN)) Q:SDECN="" Q:(SDPART'="")&(SDECN'[SDPART) D Q:(+MAXREC)&(SDECI'<MAXREC)
.S SDECC=$S($P(LSUB,"|",2)'="":$P(LSUB,"|",2),1:0)
.S LSUB=""
.F S SDECC=$O(^VA(200,"B",SDECN,SDECC)) Q:SDECC'>0 D Q:(+MAXREC)&(SDECI'<MAXREC)
..I $$PC(SDECC),'INACT D USRDG^SDEC01B(SDECC) Q ;$$ISTERM^USRLM(SDECC) Q
..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECC_U_SDECN_U_SDECN_"|"_SDECC_U_$$PC(SDECC)_$C(30)
I (SDECI>0),('MAXREC)!(SDECI<MAXREC) D
.S SDTMP=$P(^TMP("SDEC",$J,SDECI),$C(30),1)
.S $P(SDTMP,U,3)=""
.S ^TMP("SDEC",$J,SDECI)=SDTMP_$C(30)
Q
PC(USR,SDT,EFFDT,EXPDT,SDF) ;is USR active - does USR have an active PERSON CLASS
;PC called from NP2 above and SDEC1A
; USR - (required) pointer to NEW PERSON file 200
; SDT - (optional) date in FM format to determine active status; default to 'today'
; SDF - (optional) flags
; 1. do not check TERMINATION DATE
;RETURN:
; 0=active; 1=inactive
; .EFFDT - latest effective date
; .EXPDT - latest expiration date; "" if no expiration against current active
N RET,SDI,TD,EFF,EXP
S SDF=$G(SDF,0)
S RET=1
I '$E(SDF) S TD=$$GET1^DIQ(200,USR_",",9.2,"I") I TD'="",TD'>DT G:+RET PCX ; ICR #10060 wtc 756 7/12/2019
S (EFFDT,EXPDT)=""
I $G(USR)="" Q 1
S SDT=$G(SDT) I SDT="" S SDT=DT
I SDT'?7N Q RET
S SDI=0 F S SDI=$O(^VA(200,USR,"USC1",SDI)) Q:SDI'>0 D Q:RET=0
. ;
. ; Replaced lines below with ICR-compliant lines. wtc 756 7/12/2019
. ;
. ;S EFF=$P(^VA(200,USR,"USC1",SDI,0),U,2)
. ;S EXP=$P(^VA(200,USR,"USC1",SDI,0),U,3)
. S EFF=$$GET1^DIQ(200.05,SDI_","_USR_",",2,"I") ; ICR #10060 wtc 756 7/12/2019
. S EXP=$$GET1^DIQ(200.05,SDI_","_USR_",",3,"I") ; ICR #10060 wtc 756 7/12/2019
.I EFF'="",EFF>EFFDT S EFFDT=EFF
.I EXP'="",EXP>EXPDT S EXPDT=EXP
.I SDT'<EFF,(EXP="")!(SDT<EXP) S RET=0 S EFFDT=EFF S EXPDT=$S(EXP'="":EXP,1:"")
PCX ;
Q RET
;
;S SDIEN=0 F S SDIEN=$O(^XUSEC("PROVIDER",SDIEN)) Q:SDIEN'>0 D
;.S SDINACT=$$GET1^DIQ(200,SDIEN_",",53.4,"I")
;.I SDINACT'="" S:SDINACT>$$NOW^XLFDT SDINACT=""
;.I SDINACT="" D
;..S SDECN=$$GET1^DIQ(200,SDIEN_",",.01)
;..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDIEN_U_SDECN_$C(30)
;S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
;Q
;
;Q
;
ACCTYPE(SDECY) ;return active entries from the SDEC ACCESS TYPE file 409.823
;ACCTYPE(SDECY) external parameter tag is in SDEC
; INPUT: none
N SDECC,SDECI,SDECN,SDECNOD
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020SDEC_ACCESS_TYPE_IEN^T00020NAME^T00020INACTIVE^T00020DEPARTMENT_NAME^T00020DISPLAY_COLOR^T00020RED^T00020GREEN^T00020BLUE^T00020PREVENT_ACCESS"_$C(30)
S SDECN=""
F S SDECN=$O(^SDEC(409.823,"B",SDECN)) Q:SDECN="" D
. S SDECC=$O(^SDEC(409.823,"B",SDECN,""))
. S SDECIN=$$GET1^DIQ(409.823,SDECC_",",.02)
. I SDECIN'="YES" D
. . S SDECNOD=SDECC_U_$$GET1^DIQ(409.823,SDECC_",",.01)_U_SDECIN
. . S SDECNOD=SDECNOD_U_$$GET1^DIQ(409.823,SDECC_",",.03)_U_$$GET1^DIQ(409.823,SDECC_",",.04)_U_$$GET1^DIQ(409.823,SDECC_",",.05)
. . S SDECNOD=SDECNOD_U_$$GET1^DIQ(409.823,SDECC_",",.06)_U_$$GET1^DIQ(409.823,SDECC_",",.07)_U_$$GET1^DIQ(409.823,SDECC_",",.08)
. . S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECNOD_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
ACCGROUP(SDECY) ;return active entries from the SDEC ACCESS GROUP file 409.822
;ACCGROUP(SDECY) external parameter tag is in SDEC
; INPUT: none
N SDECC,SDECI,SDECN,SDECNOD
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020SDEC_ACCESS_GROUP_IEN^T00020NAME"_$C(30)
S SDECN=""
F S SDECN=$O(^SDEC(409.822,"B",SDECN)) Q:SDECN="" D
. S SDECC=$O(^SDEC(409.822,"B",SDECN,""))
. S SDECNOD=SDECC_U_$$GET1^DIQ(409.822,SDECC_",",.01)
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECNOD_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
RESUSER(SDECY,SDRES) ;SDEC RESOURCE USER remote procedure returns all entries from the SDEC RESOURCE USER file 409.833
;RESUSER(SDECY,SDRES) external parameter tag is in SDEC
; INPUT:
; SDRES = Resource ID pointer to SDEC RESOURCE file 409.831
;RETURN:
; Returns a Global Array in which each array entry contains data from the SDEC RESOURCE USER file separated by ^:
; 1. SDEC_RESOURCE_USER_IEN
; 2. RESOURCE_NAME
; 3. RESOURCE_ID
; 4. OVERBOOK
; 5. MODIFY_SCHEDULE
; 6. MODIFY_APPTS
; 7. USERNAME
; 8. USER_ID
; 9. MASTEROVERBOOK
N SDECC,SDECI,SDECN,SDECNOD
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
; 1 2 3 4 5
S SDECTMP="T00020SDEC_RESOURCE_USER_IEN^T00020RESOURCE_NAME^T00020RESOURCE_ID^T00020OVERBOOK^T00020MODIFY_SCHEDULE^"
; 6 7 8 9
S SDECTMP=SDECTMP_"T00020MODIFY_APPTS^T00020USERNAME^T00020USER_ID^T00020MASTEROVERBOOK"_$C(30)
S ^TMP("SDEC",$J,0)=SDECTMP
S SDRES=$G(SDRES)
I SDRES'="",'$D(^SDEC(409.831,+SDRES,0)) S ^TMP("SDEC",$J,1)="-1^Invalid Resource ID." Q
I SDRES'="" S SDECC=0 F S SDECC=$O(^SDEC(409.833,"B",+SDRES,SDECC)) Q:SDECC'>0 D GET1
I SDRES="" S SDECC=0 F S SDECC=$O(^SDEC(409.833,SDECC)) Q:SDECC'>0 D GET1
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
GET1 ;
N TD
S SDECNOD=^SDEC(409.833,SDECC,0)
;Q:$$PC($P(SDECNOD,U,2))
S TD=$$GET1^DIQ(200,$P(SDECNOD,U,2)_",",9.2,"I") I TD'="",TD'>DT Q ; ICR #10060 wtc 756 7/12/2019
S SDECTMP=SDECC ;1. resource user ID
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.01) ;2. resource name
S SDECTMP=SDECTMP_U_$P(SDECNOD,U,1) ;3. resource ID - pointer to SDEC RESOURCE
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.03) ;4. overbook
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.04) ;5. modify schedule
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.05) ;6. modify appointments
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.02) ;7. user name
S SDECTMP=SDECTMP_U_$P(SDECNOD,U,2) ;8. user ID
S SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.06) ;9. master overbook
S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
Q
;
HOLIDAY(SDECY,SDECBD) ;return all entries from the HOLIDAY file 40.5
;HOLIDAY(SDECY,SDECBD) external parameter tag is in SDEC
; INPUT: SDECBD = begin date in external format (defaults to 'today')
N SDECC,SDECI,SDECN,SDECNOD,SDECTMP,%DT,X,Y
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
I $G(SDECBD)'=""&(SDECBD'="1/1/0001@00:00") D
. S X=$P(SDECBD,"@",1)
. S %DT=""
. D ^%DT
. S SDECBD=Y
I SDECBD=-1 D ERR("SDEC45: Invalid date specified.") Q
I $G(SDECBD)="" S SDECBD=$$DT^XLFDT() ;default to 'today'
I $$FR^XLFDT(SDECBD) S SDECBD=$$DT^XLFDT() ;check if date in valid range
S ^TMP("SDEC",$J,0)="T00020SDEC_HOLIDAY_DATE^T00020HOLIDAY_NAME"_$C(30)
S SDECN=SDECBD-1
F S SDECN=$O(^HOLIDAY("B",SDECN)) Q:SDECN="" D
. S SDECC=$O(^HOLIDAY("B",SDECN,""))
. S SDECTMP=$$FMTE^XLFDT($P(^HOLIDAY(SDECC,0),"^",1),5) ;holiday date ; ICR #10 wtc 756 7/12/2019
. S SDECTMP=SDECTMP_U_$$GET1^DIQ(40.5,SDECC_",",2) ;holiday name ; ICR #10 wtc 756 7/12/2019
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
CLINPROV(SDECY,SDECCL) ;return all providers for a given clinic from the HOSPITAL LOCATION file 44
;CLINPROV(SDECY,SDECCL) external parameter tag is in SDEC
; INPUT: SDECCL = Clinic (Hospital Location) IEN from file 44 ^SC
N SDECC,SDECI,SDECN,SDECNOD,SDECTMP
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
;check inputs
S ^TMP("SDEC",$J,0)="T00020ERRORID"_$C(30)
I $G(SDECCL)="" D ERR("SDEC45: Clinic not specified.") Q
I '$D(^SC(SDECCL)) D ERR("SDEC45: Invalid clinic specified.") Q
S ^TMP("SDEC",$J,0)="T00020PROVIDER_IEN^T00020PROVIDER_NAME^T00030DEFAULT"_$C(30)
S SDECC=0
F S SDECC=$O(^SC(SDECCL,"PR",SDECC)) Q:SDECC'>0 D
. S SDECNOD=^SC(SDECCL,"PR",SDECC,0)
. S SDECTMP=$P(SDECNOD,U,1) ;provider IEN
. D RESPRV1^SDEC01B(SDECTMP,SDECCL)
. S $P(SDECTMP,U,2)=$$GET1^DIQ(200,SDECTMP_",",.01) ;provider name ; ICR #10060 wtc 756 7/12/2019
. S $P(SDECTMP,U,3)=$S($P(SDECNOD,U,2)=1:"YES",1:"NO") ;default provider
. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDECTMP_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
PROVALL(SDECY,SDECCL) ;return all providers for a given clinic from the HOSPITAL LOCATION file 44
;PROVALL(SDECY,SDECCL) external parameter tag is in SDEC
; INPUT: SDECCL = Clinic (Hospital Location) IEN from file 44 ^SC
N SDECC,SDECI,SDECN,SDECNOD,SDECTMP,SDECARRI,SDECCL,SDECARRN,SDECPRNM,SDECIEN
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
;check inputs
S ^TMP("SDEC",$J,0)="T00020PROVIDER_IEN^T00030PROVIDER_NAME"_$C(30)
S SDECCL=0
F S SDECCL=$O(^SC(SDECCL)) Q:'SDECCL D
. S SDECC=0
. F S SDECC=$O(^SC(SDECCL,"PR",SDECC)) Q:SDECC'>0 D
. . S SDECNOD=^SC(SDECCL,"PR",SDECC,0)
. . S SDECTMP=$P(SDECNOD,U,1) ;provider IEN
. . D RESPRV1^SDEC01B(SDECTMP,SDECCL)
. . S SDECARRI(SDECTMP)="" ; Save array of Provider IENs
S SDECTMP="" F S SDECTMP=$O(SDECARRI(SDECTMP)) Q:SDECTMP="" D
. S SDECPRNM=$$GET1^DIQ(200,SDECTMP_",",.01) ; ICR #10060 wtc 756 7/12/2019
. S:SDECPRNM'="" SDECARRN(SDECPRNM)=SDECTMP
S SDECPRNM="" F S SDECPRNM=$O(SDECARRN(SDECPRNM)) Q:SDECPRNM="" D
. S SDECIEN=SDECARRN(SDECPRNM)
. S SDECI=SDECI+1
. S ^TMP("SDEC",$J,SDECI)=SDECIEN_U_SDECPRNM_$C(30)
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
PROVCLIN(SDECY,SDECPRV) ;PROVIDER CLINICS remote procedure
;PROVCLIN(SDECY,SDECPRV) external parameter tag is in SDEC
; return all clinics for a given provider from the NEW PERSON file 200
; INPUT: SDECPRV = Provider (NEW PERSON) IEN from file 200
N SDECC,SDECI,SDECN,SDECNOD,SDECTMP
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
;check inputs
S ^TMP("SDEC",$J,0)="T00020ERRORID"_$C(30)
I $G(SDECPRV)="" D ERR("SDEC45: Provider not specified.") Q
I '$D(^VA(200,SDECPRV)) D ERR("SDEC45: Invalid provider specified.") Q
S ^TMP("SDEC",$J,0)="T00020CLINIC_IEN^T00020CLINIC_NAME"_$C(30)
D CLINICS
S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
Q
;
CLINICS ; -- sets ^TMP for provider's clinics
NEW CLN,IEN,NAME
S CLN=0 F S CLN=$O(^SC("AVADPR",SDECPRV,CLN)) Q:'CLN D
. S IEN=0 F S IEN=$O(^SC("AVADPR",SDECPRV,CLN,IEN)) Q:'IEN D
.. ;I ^SC("AVADPR",SDECPRV,CLN,IEN)'=1 Q ;not default provider
.. Q:$$GET1^DIQ(44,CLN_",",50.01,"I")=1 ;OOS?
.. D RESPRV1^SDEC01B(SDECPRV,IEN)
.. S NAME=$$GET1^DIQ(44,CLN,.01)
.. S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=CLN_U_NAME_$C(30)
Q
;
HIDE(SDECY) ; --- Returns list of clinics that are Hidden
N IEN,NAME,SDECI
S SDECI=0
K ^TMP("SDEC",$J)
S SDECY="^TMP(""SDEC"","_$J_")"
S ^TMP("SDEC",$J,0)="T00020CLINIC_IEN^T00020CLINIC_NAME"_$C(30,31)
Q
ERROR ;
D ERR("VISTA Error")
Q
;
ERR(ERRNO) ;Error processing
S SDECI=SDECI+1
S ^TMP("SDEC",$J,SDECI)=ERRNO_$C(30,31)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC45 16069 printed Dec 13, 2024@02:50:36 Page 2
SDEC45 ;ALB/SAT,JAS - VISTA SCHEDULING UTILITY RPCS TO RETURN VARIOUS CLINIC AND USER DATA ;May 8, 2023
+1 ;;5.3;Scheduling;**627,642,658,756,845**;Aug 13, 1993;Build 8
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; ICR
+5 ; ---
+6 ; ACCESS TO HOLIDAY FILE SUPPORTED BY ICR 10
+7 ; ACCESS TO FILE #200 New Person SUPPORTED BY ICR 10060
+8 ;
+9 QUIT
+10 ;
CLINSTOP(SDECY,SDP) ;CLINIC STOP remote procedure ;alb/sat 658 - add SDP for Partial Name input
+1 ;return entries from the CLINIC STOP file (#40.7)
+2 NEW SDECC,SDECI,SDECNOD,SDIEN
+3 ;
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 SET ^TMP("SDEC",$JOB,0)="T00020CLINIC_STOP_IEN^T00020CODE^T00020NAME"_$CHAR(30)
+8 ;alb/sat 658
SET SDP=$GET(SDP)
+9 ;alb/sat 658 - set SDECN to partial name
SET SDECN=$SELECT(SDP'="":$$GETSUB^SDECU(SDP),1:"")
+10 ;alb/sat 658 - check if within partial name bounds
FOR
SET SDECN=$ORDER(^DIC(40.7,"B",SDECN))
if SDECN=""
QUIT
if (SDP'="")&(SDECN'[SDP)
QUIT
Begin DoDot:1
+11 SET SDECC=""
FOR
SET SDECC=$ORDER(^DIC(40.7,"B",SDECN,SDECC))
if SDECC=""
QUIT
Begin DoDot:2
+12 SET SDECNOD=^DIC(40.7,SDECC,0)
+13 IF $PIECE(SDECNOD,U,3)'=""
IF $PIECE($PIECE(SDECNOD,U,3),".",1)'>$PIECE($$NOW^XLFDT,".",1)
QUIT
+14 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECC_U_$PIECE(SDECNOD,U,2)_U_$PIECE(SDECNOD,U,1)_$CHAR(30)
End DoDot:2
End DoDot:1
+15 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+16 QUIT
+17 ;
CANREAS(SDECY,SDECIN) ;return active/inactive entries from the CANCELLATION REASONS file 409.2
+1 ;CANREAS(SDECY,SDECIN) external parameter tag is in SDEC
+2 ; INPUT: SDECIN - (optional) Flag: show inactive 0=active only (default); 1=show active and inactive
+3 NEW SDECC,SDECI,SDECNOD,SDTYPE
+4 ;
+5 SET SDECI=0
+6 KILL ^TMP("SDEC",$JOB)
+7 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+8 SET ^TMP("SDEC",$JOB,0)="T00020CANCELLATION_REASONS_IEN^T00020NAME^T00030TYPE^T00030SYSTEM_USE_ONLY"_$CHAR(30)
+9 ;default to active only
if ($GET(SDECIN)="")!("01"'[$GET(SDECIN))
SET SDECIN=0
+10 SET SDECN=""
+11 FOR
SET SDECN=$ORDER(^SD(409.2,"B",SDECN))
if SDECN=""
QUIT
Begin DoDot:1
+12 SET SDECC=$ORDER(^SD(409.2,"B",SDECN,""))
+13 SET SDECNOD=^SD(409.2,SDECC,0)
+14 IF SDECIN!($PIECE($GET(SDECNOD),U,4)'=1)
Begin DoDot:2
+15 SET SDTYPE=$SELECT($PIECE(SDECNOD,U,2)="P":"PATIENT",$PIECE(SDECNOD,U,2)="C":"CLINIC",$PIECE(SDECNOD,U,2)="B":"BOTH",1:"")
+16 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECC_U_$PIECE(SDECNOD,U,1)_U_SDTYPE_U_$SELECT($PIECE(SDECNOD,U,6)=1:"YES",1:"NO")_$CHAR(30)
End DoDot:2
End DoDot:1
+17 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+18 QUIT
+19 ;
CANCMT(SDECY,TYPE) ;return entries from the SDEC CANCELLATION COMMENT file (#409.88)
+1 ;
+2 ; SDEC CNCMT RPC - SD*5.3*756 wtc 6/8/2020
+3 ;
+4 ; TYPE = "NATIONAL" or "LOCAL" [REQUIRED]
+5 ;
+6 ; Returns list of canned comment hashtags, type and text equivalent or -1^error text
+7 ;
+8 ;
NEW SDIEN,SDECI,SDECTAG
+9 ;
+10 ;
KILL ^TMP("SDEC",$JOB)
SET SDECY="^TMP(""SDEC"","_$JOB_")"
+11 ;
SET SDECI=0
SET ^TMP("SDEC",$JOB,0)="T00020CANCELLATION_COMMENT_HASHTAG^T00020TYPE^T00080CANCELLATION_COMMENT_TEXT"_$CHAR(30)
+12 ;
+13 ;
IF $GET(TYPE)=""
DO ERR("-1^Missing type")
QUIT
+14 ;
IF TYPE'="NATIONAL"
IF TYPE'="LOCAL"
DO ERR("-1^Invalid type")
QUIT
+15 ;
+16 ; Scan SDEC CANCELLATION COMMENT file (#409.88) in hash tag (field #.01) order and load in output array.
+17 ;
+18 ;
SET SDECI=0
SET SDECTAG=""
+19 ;
FOR
SET SDECTAG=$ORDER(^SDEC(409.88,"B",SDECTAG))
if SDECTAG=""
QUIT
SET SDIEN=0
FOR
SET SDIEN=$ORDER(^SDEC(409.88,"B",SDECTAG,SDIEN))
if 'SDIEN
QUIT
Begin DoDot:1
+20 ;
IF TYPE="NATIONAL"
if $PIECE(^SDEC(409.88,SDIEN,0),U,3)'=1
QUIT
+21 ;
IF TYPE="LOCAL"
if $PIECE(^SDEC(409.88,SDIEN,0),U,3)=1
QUIT
+22 ;
+23 ;
SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTAG_U_TYPE_U_$PIECE(^SDEC(409.88,SDIEN,0),U,2)_$CHAR(30)
End DoDot:1
+24 ;
+25 ;
SET ^(SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+26 QUIT
+27 ;
CANCMOPT ;
+1 ;
+2 ; Create/edit local SDEC CANCELLATION COMMENT option - wtc 756 6/23/2020
+3 ;
+4 ;
NEW DIC,Y,DIE,DA,DR
+5 ;
SET DIC=409.88
SET DIC(0)="AEL"
SET DIC("S")="I $P(^(0),U,3)'=1"
DO ^DIC
if Y<0
QUIT
+6 ;
SET DIE="^SDEC(409.88,"
SET DA=+Y
SET DR=".01;1;2///0"
DO ^DIE
+7 ;
QUIT
+8 ;
NEWPERS(SDECY,SDCLASS,SDPART,MAXREC,LSUB,INACT) ;return entries from the USR CLASS MEMBERSHIP file that have the 'PROVIDER' USR CLASS
+1 ;NEWPERS(SDECY,SDCLASS) external parameter tag is in SDEC
+2 ; INPUT:
+3 ; SDCLASS - (not used) usr class ID pointer to USR CLASS file 8930
+4 ; default is the 'PROVIDER' USR CLASS
+5 ; SDPART - (optional) Partial user name
+6 ; MAXREC - (optional) Max records returned
+7 ; LSUB - (optional) Last subscripts from previous call
+8 ; INACT - (optional) inactive flag
+9 ; 0=return only active users that do not have an active PERSON CLASS
+10 ; 1=return active AND inactive users
+11 NEW SDECI,SDECN,SDIEN,SDINACT
+12 NEW SDACT
+13 SET INACT=$GET(INACT)
+14 SET SDECI=0
+15 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+16 KILL @SDECY
+17 SET @SDECY@(SDECI)="T00020NEW_PERSON_IEN^T00020NAME^T00030LASTSUB^T00030INACTIVE"_$CHAR(30)
+18 SET SDPART=$GET(SDPART)
+19 SET MAXREC=$GET(MAXREC)
+20 SET LSUB=$GET(LSUB)
+21 DO NP2
+22 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+23 QUIT
NP2 ;partial name lookup
+1 NEW SDCLS,SDECC,SDECN,SDECNPS,SDTMP
+2 SET SDECN=$SELECT($PIECE(LSUB,"|",1)'="":$$GETSUB^SDECU($PIECE(LSUB,"|",1)),SDPART'="":$$GETSUB^SDECU(SDPART),1:"")
+3 FOR
SET SDECN=$ORDER(^VA(200,"B",SDECN))
if SDECN=""
QUIT
if (SDPART'="")&(SDECN'[SDPART)
QUIT
Begin DoDot:1
+4 SET SDECC=$SELECT($PIECE(LSUB,"|",2)'="":$PIECE(LSUB,"|",2),1:0)
+5 SET LSUB=""
+6 FOR
SET SDECC=$ORDER(^VA(200,"B",SDECN,SDECC))
if SDECC'>0
QUIT
Begin DoDot:2
+7 ;$$ISTERM^USRLM(SDECC) Q
IF $$PC(SDECC)
IF 'INACT
DO USRDG^SDEC01B(SDECC)
QUIT
+8 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECC_U_SDECN_U_SDECN_"|"_SDECC_U_$$PC(SDECC)_$CHAR(30)
End DoDot:2
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
End DoDot:1
if (+MAXREC)&(SDECI'<MAXREC)
QUIT
+9 IF (SDECI>0)
IF ('MAXREC)!(SDECI<MAXREC)
Begin DoDot:1
+10 SET SDTMP=$PIECE(^TMP("SDEC",$JOB,SDECI),$CHAR(30),1)
+11 SET $PIECE(SDTMP,U,3)=""
+12 SET ^TMP("SDEC",$JOB,SDECI)=SDTMP_$CHAR(30)
End DoDot:1
+13 QUIT
PC(USR,SDT,EFFDT,EXPDT,SDF) ;is USR active - does USR have an active PERSON CLASS
+1 ;PC called from NP2 above and SDEC1A
+2 ; USR - (required) pointer to NEW PERSON file 200
+3 ; SDT - (optional) date in FM format to determine active status; default to 'today'
+4 ; SDF - (optional) flags
+5 ; 1. do not check TERMINATION DATE
+6 ;RETURN:
+7 ; 0=active; 1=inactive
+8 ; .EFFDT - latest effective date
+9 ; .EXPDT - latest expiration date; "" if no expiration against current active
+10 NEW RET,SDI,TD,EFF,EXP
+11 SET SDF=$GET(SDF,0)
+12 SET RET=1
+13 ; ICR #10060 wtc 756 7/12/2019
IF '$EXTRACT(SDF)
SET TD=$$GET1^DIQ(200,USR_",",9.2,"I")
IF TD'=""
IF TD'>DT
if +RET
GOTO PCX
+14 SET (EFFDT,EXPDT)=""
+15 IF $GET(USR)=""
QUIT 1
+16 SET SDT=$GET(SDT)
IF SDT=""
SET SDT=DT
+17 IF SDT'?7N
QUIT RET
+18 SET SDI=0
FOR
SET SDI=$ORDER(^VA(200,USR,"USC1",SDI))
if SDI'>0
QUIT
Begin DoDot:1
+19 ;
+20 ; Replaced lines below with ICR-compliant lines. wtc 756 7/12/2019
+21 ;
+22 ;S EFF=$P(^VA(200,USR,"USC1",SDI,0),U,2)
+23 ;S EXP=$P(^VA(200,USR,"USC1",SDI,0),U,3)
+24 ; ICR #10060 wtc 756 7/12/2019
SET EFF=$$GET1^DIQ(200.05,SDI_","_USR_",",2,"I")
+25 ; ICR #10060 wtc 756 7/12/2019
SET EXP=$$GET1^DIQ(200.05,SDI_","_USR_",",3,"I")
+26 IF EFF'=""
IF EFF>EFFDT
SET EFFDT=EFF
+27 IF EXP'=""
IF EXP>EXPDT
SET EXPDT=EXP
+28 IF SDT'<EFF
IF (EXP="")!(SDT<EXP)
SET RET=0
SET EFFDT=EFF
SET EXPDT=$SELECT(EXP'="":EXP,1:"")
End DoDot:1
if RET=0
QUIT
PCX ;
+1 QUIT RET
+2 ;
+3 ;S SDIEN=0 F S SDIEN=$O(^XUSEC("PROVIDER",SDIEN)) Q:SDIEN'>0 D
+4 ;.S SDINACT=$$GET1^DIQ(200,SDIEN_",",53.4,"I")
+5 ;.I SDINACT'="" S:SDINACT>$$NOW^XLFDT SDINACT=""
+6 ;.I SDINACT="" D
+7 ;..S SDECN=$$GET1^DIQ(200,SDIEN_",",.01)
+8 ;..S SDECI=SDECI+1 S ^TMP("SDEC",$J,SDECI)=SDIEN_U_SDECN_$C(30)
+9 ;S ^TMP("SDEC",$J,SDECI)=^TMP("SDEC",$J,SDECI)_$C(31)
+10 ;Q
+11 ;
+12 ;Q
+13 ;
ACCTYPE(SDECY) ;return active entries from the SDEC ACCESS TYPE file 409.823
+1 ;ACCTYPE(SDECY) external parameter tag is in SDEC
+2 ; INPUT: none
+3 NEW SDECC,SDECI,SDECN,SDECNOD
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 SET ^TMP("SDEC",$JOB,0)="T00020SDEC_ACCESS_TYPE_IEN^T00020NAME^T00020INACTIVE^T00020DEPARTMENT_NAME^T00020DISPLAY_COLOR^T00020RED^T00020GREEN^T00020BLUE^T00020PREVENT_ACCESS"_$CHAR(30)
+8 SET SDECN=""
+9 FOR
SET SDECN=$ORDER(^SDEC(409.823,"B",SDECN))
if SDECN=""
QUIT
Begin DoDot:1
+10 SET SDECC=$ORDER(^SDEC(409.823,"B",SDECN,""))
+11 SET SDECIN=$$GET1^DIQ(409.823,SDECC_",",.02)
+12 IF SDECIN'="YES"
Begin DoDot:2
+13 SET SDECNOD=SDECC_U_$$GET1^DIQ(409.823,SDECC_",",.01)_U_SDECIN
+14 SET SDECNOD=SDECNOD_U_$$GET1^DIQ(409.823,SDECC_",",.03)_U_$$GET1^DIQ(409.823,SDECC_",",.04)_U_$$GET1^DIQ(409.823,SDECC_",",.05)
+15 SET SDECNOD=SDECNOD_U_$$GET1^DIQ(409.823,SDECC_",",.06)_U_$$GET1^DIQ(409.823,SDECC_",",.07)_U_$$GET1^DIQ(409.823,SDECC_",",.08)
+16 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECNOD_$CHAR(30)
End DoDot:2
End DoDot:1
+17 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+18 QUIT
+19 ;
ACCGROUP(SDECY) ;return active entries from the SDEC ACCESS GROUP file 409.822
+1 ;ACCGROUP(SDECY) external parameter tag is in SDEC
+2 ; INPUT: none
+3 NEW SDECC,SDECI,SDECN,SDECNOD
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 SET ^TMP("SDEC",$JOB,0)="T00020SDEC_ACCESS_GROUP_IEN^T00020NAME"_$CHAR(30)
+8 SET SDECN=""
+9 FOR
SET SDECN=$ORDER(^SDEC(409.822,"B",SDECN))
if SDECN=""
QUIT
Begin DoDot:1
+10 SET SDECC=$ORDER(^SDEC(409.822,"B",SDECN,""))
+11 SET SDECNOD=SDECC_U_$$GET1^DIQ(409.822,SDECC_",",.01)
+12 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECNOD_$CHAR(30)
End DoDot:1
+13 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+14 QUIT
+15 ;
RESUSER(SDECY,SDRES) ;SDEC RESOURCE USER remote procedure returns all entries from the SDEC RESOURCE USER file 409.833
+1 ;RESUSER(SDECY,SDRES) external parameter tag is in SDEC
+2 ; INPUT:
+3 ; SDRES = Resource ID pointer to SDEC RESOURCE file 409.831
+4 ;RETURN:
+5 ; Returns a Global Array in which each array entry contains data from the SDEC RESOURCE USER file separated by ^:
+6 ; 1. SDEC_RESOURCE_USER_IEN
+7 ; 2. RESOURCE_NAME
+8 ; 3. RESOURCE_ID
+9 ; 4. OVERBOOK
+10 ; 5. MODIFY_SCHEDULE
+11 ; 6. MODIFY_APPTS
+12 ; 7. USERNAME
+13 ; 8. USER_ID
+14 ; 9. MASTEROVERBOOK
+15 NEW SDECC,SDECI,SDECN,SDECNOD
+16 SET SDECI=0
+17 KILL ^TMP("SDEC",$JOB)
+18 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+19 ; 1 2 3 4 5
+20 SET SDECTMP="T00020SDEC_RESOURCE_USER_IEN^T00020RESOURCE_NAME^T00020RESOURCE_ID^T00020OVERBOOK^T00020MODIFY_SCHEDULE^"
+21 ; 6 7 8 9
+22 SET SDECTMP=SDECTMP_"T00020MODIFY_APPTS^T00020USERNAME^T00020USER_ID^T00020MASTEROVERBOOK"_$CHAR(30)
+23 SET ^TMP("SDEC",$JOB,0)=SDECTMP
+24 SET SDRES=$GET(SDRES)
+25 IF SDRES'=""
IF '$DATA(^SDEC(409.831,+SDRES,0))
SET ^TMP("SDEC",$JOB,1)="-1^Invalid Resource ID."
QUIT
+26 IF SDRES'=""
SET SDECC=0
FOR
SET SDECC=$ORDER(^SDEC(409.833,"B",+SDRES,SDECC))
if SDECC'>0
QUIT
DO GET1
+27 IF SDRES=""
SET SDECC=0
FOR
SET SDECC=$ORDER(^SDEC(409.833,SDECC))
if SDECC'>0
QUIT
DO GET1
+28 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+29 QUIT
GET1 ;
+1 NEW TD
+2 SET SDECNOD=^SDEC(409.833,SDECC,0)
+3 ;Q:$$PC($P(SDECNOD,U,2))
+4 ; ICR #10060 wtc 756 7/12/2019
SET TD=$$GET1^DIQ(200,$PIECE(SDECNOD,U,2)_",",9.2,"I")
IF TD'=""
IF TD'>DT
QUIT
+5 ;1. resource user ID
SET SDECTMP=SDECC
+6 ;2. resource name
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.01)
+7 ;3. resource ID - pointer to SDEC RESOURCE
SET SDECTMP=SDECTMP_U_$PIECE(SDECNOD,U,1)
+8 ;4. overbook
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.03)
+9 ;5. modify schedule
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.04)
+10 ;6. modify appointments
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.05)
+11 ;7. user name
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.02)
+12 ;8. user ID
SET SDECTMP=SDECTMP_U_$PIECE(SDECNOD,U,2)
+13 ;9. master overbook
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(409.833,SDECC_",",.06)
+14 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
+15 QUIT
+16 ;
HOLIDAY(SDECY,SDECBD) ;return all entries from the HOLIDAY file 40.5
+1 ;HOLIDAY(SDECY,SDECBD) external parameter tag is in SDEC
+2 ; INPUT: SDECBD = begin date in external format (defaults to 'today')
+3 NEW SDECC,SDECI,SDECN,SDECNOD,SDECTMP,%DT,X,Y
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 IF $GET(SDECBD)'=""&(SDECBD'="1/1/0001@00:00")
Begin DoDot:1
+8 SET X=$PIECE(SDECBD,"@",1)
+9 SET %DT=""
+10 DO ^%DT
+11 SET SDECBD=Y
End DoDot:1
+12 IF SDECBD=-1
DO ERR("SDEC45: Invalid date specified.")
QUIT
+13 ;default to 'today'
IF $GET(SDECBD)=""
SET SDECBD=$$DT^XLFDT()
+14 ;check if date in valid range
IF $$FR^XLFDT(SDECBD)
SET SDECBD=$$DT^XLFDT()
+15 SET ^TMP("SDEC",$JOB,0)="T00020SDEC_HOLIDAY_DATE^T00020HOLIDAY_NAME"_$CHAR(30)
+16 SET SDECN=SDECBD-1
+17 FOR
SET SDECN=$ORDER(^HOLIDAY("B",SDECN))
if SDECN=""
QUIT
Begin DoDot:1
+18 SET SDECC=$ORDER(^HOLIDAY("B",SDECN,""))
+19 ;holiday date ; ICR #10 wtc 756 7/12/2019
SET SDECTMP=$$FMTE^XLFDT($PIECE(^HOLIDAY(SDECC,0),"^",1),5)
+20 ;holiday name ; ICR #10 wtc 756 7/12/2019
SET SDECTMP=SDECTMP_U_$$GET1^DIQ(40.5,SDECC_",",2)
+21 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
End DoDot:1
+22 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+23 QUIT
+24 ;
CLINPROV(SDECY,SDECCL) ;return all providers for a given clinic from the HOSPITAL LOCATION file 44
+1 ;CLINPROV(SDECY,SDECCL) external parameter tag is in SDEC
+2 ; INPUT: SDECCL = Clinic (Hospital Location) IEN from file 44 ^SC
+3 NEW SDECC,SDECI,SDECN,SDECNOD,SDECTMP
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 ;check inputs
+8 SET ^TMP("SDEC",$JOB,0)="T00020ERRORID"_$CHAR(30)
+9 IF $GET(SDECCL)=""
DO ERR("SDEC45: Clinic not specified.")
QUIT
+10 IF '$DATA(^SC(SDECCL))
DO ERR("SDEC45: Invalid clinic specified.")
QUIT
+11 SET ^TMP("SDEC",$JOB,0)="T00020PROVIDER_IEN^T00020PROVIDER_NAME^T00030DEFAULT"_$CHAR(30)
+12 SET SDECC=0
+13 FOR
SET SDECC=$ORDER(^SC(SDECCL,"PR",SDECC))
if SDECC'>0
QUIT
Begin DoDot:1
+14 SET SDECNOD=^SC(SDECCL,"PR",SDECC,0)
+15 ;provider IEN
SET SDECTMP=$PIECE(SDECNOD,U,1)
+16 DO RESPRV1^SDEC01B(SDECTMP,SDECCL)
+17 ;provider name ; ICR #10060 wtc 756 7/12/2019
SET $PIECE(SDECTMP,U,2)=$$GET1^DIQ(200,SDECTMP_",",.01)
+18 ;default provider
SET $PIECE(SDECTMP,U,3)=$SELECT($PIECE(SDECNOD,U,2)=1:"YES",1:"NO")
+19 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=SDECTMP_$CHAR(30)
End DoDot:1
+20 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+21 QUIT
+22 ;
PROVALL(SDECY,SDECCL) ;return all providers for a given clinic from the HOSPITAL LOCATION file 44
+1 ;PROVALL(SDECY,SDECCL) external parameter tag is in SDEC
+2 ; INPUT: SDECCL = Clinic (Hospital Location) IEN from file 44 ^SC
+3 NEW SDECC,SDECI,SDECN,SDECNOD,SDECTMP,SDECARRI,SDECCL,SDECARRN,SDECPRNM,SDECIEN
+4 SET SDECI=0
+5 KILL ^TMP("SDEC",$JOB)
+6 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+7 ;check inputs
+8 SET ^TMP("SDEC",$JOB,0)="T00020PROVIDER_IEN^T00030PROVIDER_NAME"_$CHAR(30)
+9 SET SDECCL=0
+10 FOR
SET SDECCL=$ORDER(^SC(SDECCL))
if 'SDECCL
QUIT
Begin DoDot:1
+11 SET SDECC=0
+12 FOR
SET SDECC=$ORDER(^SC(SDECCL,"PR",SDECC))
if SDECC'>0
QUIT
Begin DoDot:2
+13 SET SDECNOD=^SC(SDECCL,"PR",SDECC,0)
+14 ;provider IEN
SET SDECTMP=$PIECE(SDECNOD,U,1)
+15 DO RESPRV1^SDEC01B(SDECTMP,SDECCL)
+16 ; Save array of Provider IENs
SET SDECARRI(SDECTMP)=""
End DoDot:2
End DoDot:1
+17 SET SDECTMP=""
FOR
SET SDECTMP=$ORDER(SDECARRI(SDECTMP))
if SDECTMP=""
QUIT
Begin DoDot:1
+18 ; ICR #10060 wtc 756 7/12/2019
SET SDECPRNM=$$GET1^DIQ(200,SDECTMP_",",.01)
+19 if SDECPRNM'=""
SET SDECARRN(SDECPRNM)=SDECTMP
End DoDot:1
+20 SET SDECPRNM=""
FOR
SET SDECPRNM=$ORDER(SDECARRN(SDECPRNM))
if SDECPRNM=""
QUIT
Begin DoDot:1
+21 SET SDECIEN=SDECARRN(SDECPRNM)
+22 SET SDECI=SDECI+1
+23 SET ^TMP("SDEC",$JOB,SDECI)=SDECIEN_U_SDECPRNM_$CHAR(30)
End DoDot:1
+24 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+25 QUIT
+26 ;
PROVCLIN(SDECY,SDECPRV) ;PROVIDER CLINICS remote procedure
+1 ;PROVCLIN(SDECY,SDECPRV) external parameter tag is in SDEC
+2 ; return all clinics for a given provider from the NEW PERSON file 200
+3 ; INPUT: SDECPRV = Provider (NEW PERSON) IEN from file 200
+4 NEW SDECC,SDECI,SDECN,SDECNOD,SDECTMP
+5 SET SDECI=0
+6 KILL ^TMP("SDEC",$JOB)
+7 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+8 ;check inputs
+9 SET ^TMP("SDEC",$JOB,0)="T00020ERRORID"_$CHAR(30)
+10 IF $GET(SDECPRV)=""
DO ERR("SDEC45: Provider not specified.")
QUIT
+11 IF '$DATA(^VA(200,SDECPRV))
DO ERR("SDEC45: Invalid provider specified.")
QUIT
+12 SET ^TMP("SDEC",$JOB,0)="T00020CLINIC_IEN^T00020CLINIC_NAME"_$CHAR(30)
+13 DO CLINICS
+14 SET ^TMP("SDEC",$JOB,SDECI)=^TMP("SDEC",$JOB,SDECI)_$CHAR(31)
+15 QUIT
+16 ;
CLINICS ; -- sets ^TMP for provider's clinics
+1 NEW CLN,IEN,NAME
+2 SET CLN=0
FOR
SET CLN=$ORDER(^SC("AVADPR",SDECPRV,CLN))
if 'CLN
QUIT
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^SC("AVADPR",SDECPRV,CLN,IEN))
if 'IEN
QUIT
Begin DoDot:2
+4 ;I ^SC("AVADPR",SDECPRV,CLN,IEN)'=1 Q ;not default provider
+5 ;OOS?
if $$GET1^DIQ(44,CLN_",",50.01,"I")=1
QUIT
+6 DO RESPRV1^SDEC01B(SDECPRV,IEN)
+7 SET NAME=$$GET1^DIQ(44,CLN,.01)
+8 SET SDECI=SDECI+1
SET ^TMP("SDEC",$JOB,SDECI)=CLN_U_NAME_$CHAR(30)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
HIDE(SDECY) ; --- Returns list of clinics that are Hidden
+1 NEW IEN,NAME,SDECI
+2 SET SDECI=0
+3 KILL ^TMP("SDEC",$JOB)
+4 SET SDECY="^TMP(""SDEC"","_$JOB_")"
+5 SET ^TMP("SDEC",$JOB,0)="T00020CLINIC_IEN^T00020CLINIC_NAME"_$CHAR(30,31)
+6 QUIT
ERROR ;
+1 DO ERR("VISTA Error")
+2 QUIT
+3 ;
ERR(ERRNO) ;Error processing
+1 SET SDECI=SDECI+1
+2 SET ^TMP("SDEC",$JOB,SDECI)=ERRNO_$CHAR(30,31)
+3 QUIT
