- 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 Jan 18, 2025@03:53:22 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