SDECINIT ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
Q
;
PRE ;
Q
;
POST ;
D RPC
D CHK^SDECINI2
D INDEX^SDECINI1
;D SDWLCL^SDECINI1
D RESCLIN
D RESAV
;D RESAB^SDECINI1
D SDAPPT^SDECINI2
D SCH
Q
;
SCH ;schedule options
N NOW,QTIME,Y
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"Scheduling SDEC IDX REFRESH ..."
W !,Y
;schedule SDEC IDX REFRESH to run nightly
S QTIME=$G(XPDQUES("POS1 NIGHTJOB")) ;cannot NEW XPDQUES in this routine - XPDQUES is defined during the install questions
D:QTIME SCHTSK("SDEC IDX REFRESH",QTIME,"24H")
;schedule SDEC IDX REFRESH to run one time 'NOW'
S NOW=$G(XPDQUES("POS2 NOWJOB")) ;cannot NEW XPDQUES in this routine - XPDQUES is defined during the install questions
D:$$UP^XLFSTR(NOW)=1 ONE
Q
SCHTSK(OPTNAME,QTIME,QFREQ) ; Schedule Option
N FDA,SCHNM,DIC,X,Y,SDIEN S SDIEN=""
Q:$G(OPTNAME)=""
I $G(QTIME)="" S QTIME=$P($$NOW^XLFDT,".",1)_".02"
S QFREQ=$G(QFREQ)
S DIC(0)="I",X=OPTNAME,DIC="^DIC(19,"
D ^DIC Q:'(Y>0) S SCHNM=+Y
;D CLEAN^DILF
S FDA(19.2,"?+1,",.01)=SCHNM,X=SCHNM
I 'SCHNM D Q
.W !,OPTNAME," option can't be scheduled - option does not exist"
;S FDA(19.2,"?+1,",1)=SCHNM
S FDA(19.2,"?+1,",2)=QTIME ;$P($$NOW^XLFDT,".")_".01"
S FDA(19.2,"?+1,",6)=QFREQ
;S FDA(19.2,"?+1,",9)="SP" SP is STARTUP/PERSISTENT
D UPDATE^DIE("","FDA","SDIEN")
W !,"Scheduled option ",OPTNAME
D CLEAN^DILF
Q
ONE ;One time queue setup for SDEC IDX REFRESH
N ZTDESC,ZTDTH,ZTIO,ZTRTN
S ZTRTN="ENTRY^SDECIDX"
S ZTIO=""
S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,1)
S ZTDESC="One time Queue: SDEC IDX REFRESH"
D ^%ZTLOAD
Q
;
RPC ;register SDEC rpcs
N Y
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"Registering new RPCs..."
W !,Y
D REGNMSP^SDECRPC("SDEC","SDECRPC")
D REGNMSP^SDECRPC("DG SENSITIVE RECORD ACCESS","SDECRPC")
D REGNMSP^SDECRPC("DG CHK BS5 XREF ARRAY","SDECRPC")
D REGNMSP^SDECRPC("ORPRF HASFLG","SDECRPC")
D REGNMSP^SDECRPC("ORPRF GETFLG","SDECRPC")
D REGNMSP^SDECRPC("ORWPT DIEDON","SDECRPC")
D REGNMSP^SDECRPC("ORWPT ID INFO","SDECRPC")
D REGNMSP^SDECRPC("ORWPT LAST5","SDECRPC")
D REGNMSP^SDECRPC("ORWPT LAST5 RPL","SDECRPC")
D REGNMSP^SDECRPC("ORWU USERINFO","SDECRPC")
Q
;
RESCLIN ;populate SDEC RESOURCE with clinics from file 44
N SDCL,SDCLN,SDDATA,SDFDA,SDFIELDS,SDFOUND,SDI,SDIEN,SDMSG,SDRESH,SDRES11,SDTS,Y
N SDIN,SDRN
S SDRESH=""
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"Updating new SDEC RESOURCE file 409.831 with clinics and providers from file 44..."
W !,Y
;D SDRTYP(.SDRTYP)
D CLEAR^SDECU ;purge SDEC RESOURCE USER file
D RESDGA^SDEC01B ;remove inactive resources from SDEC RESOURCE GROUPs
S SDCL=0 F S SDCL=$O(^SC(SDCL)) Q:SDCL'>0 D
.D RESCLIN1^SDEC01B(SDCL,.SDRESH)
.;populate from providers and privileged users
.D RESPRVA
Q
;
RESPRVA ;called from RSCLIN
;K SDDATA,SDMSG
N SDFOUND,TD
S SDFOUND=0
S SDJ=0 F S SDJ=$O(^SC(SDCL,"PR",SDJ)) Q:SDJ'>0 D
.S SDPRV=$P($G(^SC(SDCL,"PR",SDJ,0)),U,1)
.S SDPRVN=$$UP^XLFSTR($$GET1^DIQ(200,SDPRV_",",.01))
.Q:SDPRVN=""
.D RESPRV1^SDEC01B(SDPRV,SDCL,SDPRVN)
S SDJ=0 F S SDJ=$O(^SC(SDCL,"SDPRIV",SDJ)) Q:SDJ'>0 D
.S SDPRV=$P($G(^SC(SDCL,"SDPRIV",SDJ,0)),U,1)
.S SDPRVN=$$UP^XLFSTR($$GET1^DIQ(200,SDPRV_",",.01))
.Q:SDPRVN=""
.S TD=$$GET1^DIQ(200,SDJ_",",9.2,"I")
.I TD'="",$P(TD,".",1)'>$P($$NOW^XLFDT,".",1) Q ;only process active entries
.;MGH commented out
.D RESPRV1^SDEC01B(SDPRV,SDCL,SDPRVN) ;add to SDEC RESOURCE
.D:$G(SDRESH)'="" RESUPRV1 ;add to SDEC RESOURCE USER
Q
RESUPRV1 ;add privileged provider to SDEC RESOURCE USER
N SDF,SDFDA,SDIEN,SDMSG,SDNOD,SDRU
S SDF=0
Q:$O(^SDEC(409.833,"AD",SDRESH,SDPRV,0)) ;stop if existing SDEC RESOURCE USER id with provider ID.
S SDRU="+1"
;
S SDFDA=$NA(SDFDA(409.833,SDRU_","))
S @SDFDA@(.01)=SDRESH
S @SDFDA@(.02)=SDPRV
D UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
Q
;
SDRTYP(SDRTYP) ;build array of resource types
;INPUT: none
;RETURN:
; .SDRTYP - array of resource types
; SDRTYP(<ien><file ref> , <SDEC RESOURCE ien>)=""
Q
N SDI,SDTYP
K SDRTYP
S SDI=0 F S SDI=$O(^SDEC(409.831,SDI)) Q:SDI'>0 D
.S SDTYP=$$GET1^DIQ(409.831,SDI_",",.012,"I")
.I SDTYP'="" S SDRTYP(SDTYP,SDI)=""
Q
;
RESAV ;add AVAILABLE and UNAVAILABLE to SDEC ACCESS TYPE file
N Y
S Y=$$NOW^XLFDT,Y=$$FMTE^XLFDT(Y)
W !!,"Updating SDEC ACCESS TYPE file 409.823 with entries for ""AVAILABLE"" and ""UNAVAILABLE""..."
W !,Y
I '$O(^SDEC(409.823,"B","AVAILABLE",0)) D AVAILADD("AVAILABLE")
I '$O(^SDEC(409.823,"B","UNAVAILABLE",0)) D AVAILADD("UNAVAILABLE")
Q
AVAILADD(SDTXT) ;add to SDEC ACCESS TYPE file
N SDAV,SDFDA
S SDAV=$O(^SDEC(409.823,"B",SDTXT,0))
Q:+SDAV
S SDFDA(409.823,"+1,",.01)=SDTXT
S SDFDA(409.823,"+1,",.04)=$S(SDTXT="AVAILABLE":"YELLOW",1:"GRAY")
S SDFDA(409.823,"+1,",.05)=$S(SDTXT="AVAILABLE":247,1:230)
S SDFDA(409.823,"+1,",.06)=$S(SDTXT="AVAILABLE":254,1:230)
S SDFDA(409.823,"+1,",.07)=$S(SDTXT="AVAILABLE":46,1:230)
S SDFDA(409.823,"+1,",.08)=0 ;$S(SDTXT="AVAILABLE":0,1:1)
D UPDATE^DIE("","SDFDA")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECINIT 5187 printed Apr 09, 2024@21:40:42 Page 2
SDECINIT ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 QUIT
+4 ;
PRE ;
+1 QUIT
+2 ;
POST ;
+1 DO RPC
+2 DO CHK^SDECINI2
+3 DO INDEX^SDECINI1
+4 ;D SDWLCL^SDECINI1
+5 DO RESCLIN
+6 DO RESAV
+7 ;D RESAB^SDECINI1
+8 DO SDAPPT^SDECINI2
+9 DO SCH
+10 QUIT
+11 ;
SCH ;schedule options
+1 NEW NOW,QTIME,Y
+2 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+3 WRITE !!,"Scheduling SDEC IDX REFRESH ..."
+4 WRITE !,Y
+5 ;schedule SDEC IDX REFRESH to run nightly
+6 ;cannot NEW XPDQUES in this routine - XPDQUES is defined during the install questions
SET QTIME=$GET(XPDQUES("POS1 NIGHTJOB"))
+7 if QTIME
DO SCHTSK("SDEC IDX REFRESH",QTIME,"24H")
+8 ;schedule SDEC IDX REFRESH to run one time 'NOW'
+9 ;cannot NEW XPDQUES in this routine - XPDQUES is defined during the install questions
SET NOW=$GET(XPDQUES("POS2 NOWJOB"))
+10 if $$UP^XLFSTR(NOW)=1
DO ONE
+11 QUIT
SCHTSK(OPTNAME,QTIME,QFREQ) ; Schedule Option
+1 NEW FDA,SCHNM,DIC,X,Y,SDIEN
SET SDIEN=""
+2 if $GET(OPTNAME)=""
QUIT
+3 IF $GET(QTIME)=""
SET QTIME=$PIECE($$NOW^XLFDT,".",1)_".02"
+4 SET QFREQ=$GET(QFREQ)
+5 SET DIC(0)="I"
SET X=OPTNAME
SET DIC="^DIC(19,"
+6 DO ^DIC
if '(Y>0)
QUIT
SET SCHNM=+Y
+7 ;D CLEAN^DILF
+8 SET FDA(19.2,"?+1,",.01)=SCHNM
SET X=SCHNM
+9 IF 'SCHNM
Begin DoDot:1
+10 WRITE !,OPTNAME," option can't be scheduled - option does not exist"
End DoDot:1
QUIT
+11 ;S FDA(19.2,"?+1,",1)=SCHNM
+12 ;$P($$NOW^XLFDT,".")_".01"
SET FDA(19.2,"?+1,",2)=QTIME
+13 SET FDA(19.2,"?+1,",6)=QFREQ
+14 ;S FDA(19.2,"?+1,",9)="SP" SP is STARTUP/PERSISTENT
+15 DO UPDATE^DIE("","FDA","SDIEN")
+16 WRITE !,"Scheduled option ",OPTNAME
+17 DO CLEAN^DILF
+18 QUIT
ONE ;One time queue setup for SDEC IDX REFRESH
+1 NEW ZTDESC,ZTDTH,ZTIO,ZTRTN
+2 SET ZTRTN="ENTRY^SDECIDX"
+3 SET ZTIO=""
+4 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,,,1)
+5 SET ZTDESC="One time Queue: SDEC IDX REFRESH"
+6 DO ^%ZTLOAD
+7 QUIT
+8 ;
RPC ;register SDEC rpcs
+1 NEW Y
+2 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+3 WRITE !!,"Registering new RPCs..."
+4 WRITE !,Y
+5 DO REGNMSP^SDECRPC("SDEC","SDECRPC")
+6 DO REGNMSP^SDECRPC("DG SENSITIVE RECORD ACCESS","SDECRPC")
+7 DO REGNMSP^SDECRPC("DG CHK BS5 XREF ARRAY","SDECRPC")
+8 DO REGNMSP^SDECRPC("ORPRF HASFLG","SDECRPC")
+9 DO REGNMSP^SDECRPC("ORPRF GETFLG","SDECRPC")
+10 DO REGNMSP^SDECRPC("ORWPT DIEDON","SDECRPC")
+11 DO REGNMSP^SDECRPC("ORWPT ID INFO","SDECRPC")
+12 DO REGNMSP^SDECRPC("ORWPT LAST5","SDECRPC")
+13 DO REGNMSP^SDECRPC("ORWPT LAST5 RPL","SDECRPC")
+14 DO REGNMSP^SDECRPC("ORWU USERINFO","SDECRPC")
+15 QUIT
+16 ;
RESCLIN ;populate SDEC RESOURCE with clinics from file 44
+1 NEW SDCL,SDCLN,SDDATA,SDFDA,SDFIELDS,SDFOUND,SDI,SDIEN,SDMSG,SDRESH,SDRES11,SDTS,Y
+2 NEW SDIN,SDRN
+3 SET SDRESH=""
+4 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+5 WRITE !!,"Updating new SDEC RESOURCE file 409.831 with clinics and providers from file 44..."
+6 WRITE !,Y
+7 ;D SDRTYP(.SDRTYP)
+8 ;purge SDEC RESOURCE USER file
DO CLEAR^SDECU
+9 ;remove inactive resources from SDEC RESOURCE GROUPs
DO RESDGA^SDEC01B
+10 SET SDCL=0
FOR
SET SDCL=$ORDER(^SC(SDCL))
if SDCL'>0
QUIT
Begin DoDot:1
+11 DO RESCLIN1^SDEC01B(SDCL,.SDRESH)
+12 ;populate from providers and privileged users
+13 DO RESPRVA
End DoDot:1
+14 QUIT
+15 ;
RESPRVA ;called from RSCLIN
+1 ;K SDDATA,SDMSG
+2 NEW SDFOUND,TD
+3 SET SDFOUND=0
+4 SET SDJ=0
FOR
SET SDJ=$ORDER(^SC(SDCL,"PR",SDJ))
if SDJ'>0
QUIT
Begin DoDot:1
+5 SET SDPRV=$PIECE($GET(^SC(SDCL,"PR",SDJ,0)),U,1)
+6 SET SDPRVN=$$UP^XLFSTR($$GET1^DIQ(200,SDPRV_",",.01))
+7 if SDPRVN=""
QUIT
+8 DO RESPRV1^SDEC01B(SDPRV,SDCL,SDPRVN)
End DoDot:1
+9 SET SDJ=0
FOR
SET SDJ=$ORDER(^SC(SDCL,"SDPRIV",SDJ))
if SDJ'>0
QUIT
Begin DoDot:1
+10 SET SDPRV=$PIECE($GET(^SC(SDCL,"SDPRIV",SDJ,0)),U,1)
+11 SET SDPRVN=$$UP^XLFSTR($$GET1^DIQ(200,SDPRV_",",.01))
+12 if SDPRVN=""
QUIT
+13 SET TD=$$GET1^DIQ(200,SDJ_",",9.2,"I")
+14 ;only process active entries
IF TD'=""
IF $PIECE(TD,".",1)'>$PIECE($$NOW^XLFDT,".",1)
QUIT
+15 ;MGH commented out
+16 ;add to SDEC RESOURCE
DO RESPRV1^SDEC01B(SDPRV,SDCL,SDPRVN)
+17 ;add to SDEC RESOURCE USER
if $GET(SDRESH)'=""
DO RESUPRV1
End DoDot:1
+18 QUIT
RESUPRV1 ;add privileged provider to SDEC RESOURCE USER
+1 NEW SDF,SDFDA,SDIEN,SDMSG,SDNOD,SDRU
+2 SET SDF=0
+3 ;stop if existing SDEC RESOURCE USER id with provider ID.
if $ORDER(^SDEC(409.833,"AD",SDRESH,SDPRV,0))
QUIT
+4 SET SDRU="+1"
+5 ;
+6 SET SDFDA=$NAME(SDFDA(409.833,SDRU_","))
+7 SET @SDFDA@(.01)=SDRESH
+8 SET @SDFDA@(.02)=SDPRV
+9 DO UPDATE^DIE("","SDFDA","SDIEN","SDMSG")
+10 QUIT
+11 ;
SDRTYP(SDRTYP) ;build array of resource types
+1 ;INPUT: none
+2 ;RETURN:
+3 ; .SDRTYP - array of resource types
+4 ; SDRTYP(<ien><file ref> , <SDEC RESOURCE ien>)=""
+5 QUIT
+6 NEW SDI,SDTYP
+7 KILL SDRTYP
+8 SET SDI=0
FOR
SET SDI=$ORDER(^SDEC(409.831,SDI))
if SDI'>0
QUIT
Begin DoDot:1
+9 SET SDTYP=$$GET1^DIQ(409.831,SDI_",",.012,"I")
+10 IF SDTYP'=""
SET SDRTYP(SDTYP,SDI)=""
End DoDot:1
+11 QUIT
+12 ;
RESAV ;add AVAILABLE and UNAVAILABLE to SDEC ACCESS TYPE file
+1 NEW Y
+2 SET Y=$$NOW^XLFDT
SET Y=$$FMTE^XLFDT(Y)
+3 WRITE !!,"Updating SDEC ACCESS TYPE file 409.823 with entries for ""AVAILABLE"" and ""UNAVAILABLE""..."
+4 WRITE !,Y
+5 IF '$ORDER(^SDEC(409.823,"B","AVAILABLE",0))
DO AVAILADD("AVAILABLE")
+6 IF '$ORDER(^SDEC(409.823,"B","UNAVAILABLE",0))
DO AVAILADD("UNAVAILABLE")
+7 QUIT
AVAILADD(SDTXT) ;add to SDEC ACCESS TYPE file
+1 NEW SDAV,SDFDA
+2 SET SDAV=$ORDER(^SDEC(409.823,"B",SDTXT,0))
+3 if +SDAV
QUIT
+4 SET SDFDA(409.823,"+1,",.01)=SDTXT
+5 SET SDFDA(409.823,"+1,",.04)=$SELECT(SDTXT="AVAILABLE":"YELLOW",1:"GRAY")
+6 SET SDFDA(409.823,"+1,",.05)=$SELECT(SDTXT="AVAILABLE":247,1:230)
+7 SET SDFDA(409.823,"+1,",.06)=$SELECT(SDTXT="AVAILABLE":254,1:230)
+8 SET SDFDA(409.823,"+1,",.07)=$SELECT(SDTXT="AVAILABLE":46,1:230)
+9 ;$S(SDTXT="AVAILABLE":0,1:1)
SET SDFDA(409.823,"+1,",.08)=0
+10 DO UPDATE^DIE("","SDFDA")
+11 QUIT
