- SDESCCAVAIL2 ;ALB/BWF - VISTA SCHEDULING RPCS CANCEL CLINIC AVAILABILITY UTILITIES ; August 30, 2022
- ;;5.3;Scheduling;**824**;Aug 13, 1993;Build 3
- ;;Per VHA Directive 6402, this routine should not be modified
- ;
- ;
- Q ;No Direct Call
- ;
- COED(SDCL,SDBEG,SDEND,SDMSG) ; -- scan appts for those co'ed
- N SDDA,SDATE,SD0,SDC,SDESC
- S SDESC=0,SDATE=SDBEG-.0000001
- F S SDATE=$O(^SC(SDCL,"S",SDATE)) Q:'SDATE!(SDATE>SDEND) D
- .S SDDA=0 F S SDDA=$O(^SC(SDCL,"S",SDATE,1,SDDA)) Q:'SDDA D
- ..I $$GET1^DIQ(44.003,SDDA_","_SDATE_","_SDCL_",",310,"I")="C" Q
- ..I $$GET1^DIQ(44.003,SDDA_","_SDATE_","_SDCL_",",303,"I") S SDESC=1
- Q SDESC
- ;
- CHKOVERLAP(CANARY,FROM,TO) ;
- N CHKDT,SDERR
- S (CHKDT,SDERR)=0
- F S CHKDT=$O(CANARY(CHKDT)) Q:'CHKDT!(SDERR) D
- .S SDERR=$S(FROM'<CHKDT&(FROM<CANARY(CHKDT)):1,TO>CHKDT&(TO<CANARY(CHKDT)):1,1:0) Q:SDERR
- .I CHKDT'<FROM&(CHKDT<TO) S SDERR=1 Q
- I $G(SDERR) Q 1
- Q 0
- ;
- TC(TIME,SD,STARTOFDAY,SI) ;
- N %DT,X,Y,SDXX,FTIME,MSG
- ; fix times less than 4 characters
- S FTIME=SD_"."_TIME
- S FTIME=$P($$FMTE^XLFDT(FTIME,"T"),"@",2)
- S FTIME=$TR(FTIME,":","")
- S X=$$FMTE^XLFDT(SD)_"@"_FTIME,%DT="T"
- D ^%DT
- I Y<0!(X["?") Q ""
- S X=$E($P(Y_"0000",".",2),1,4)
- S SDXX=$E(X,3,4)
- S SDXX=X\100-STARTOFDAY*SI+(SDXX*SI\60)*2
- I SDXX<0 S MSG="Day Starts at "_STARTOFDAY,Y=-1
- I SDXX>72 S MSG="Day Ends prior to provided end time "_X,Y=-1
- Q X_U_Y_U_SDXX_U_$G(MSG)
- ;
- CK1(CANDTTM,DFN,SDIV) ;
- N SDX,SD1,CANDATE,CANDATELOOP,SDQUIT,STATUS,CANDATE
- S SDQUIT=0
- S (CANDATELOOP,CANDATE)=$P(CANDTTM,".")
- F S CANDATELOOP=$O(^DPT(DFN,"S",CANDATELOOP)) Q:'CANDATELOOP!(CANDATELOOP'=CANDATE) D
- .S STATUS=$$GET1^DIQ(2.98,CANDATELOOP_","_DFN_",",3,"I")
- .I STATUS'["C",STATUS'["N" S SDQUIT=1
- Q:SDQUIT
- F SD1=2,4 I $D(^SC("AAS",CANDTTM,CANDATE,DFN)) S SDQUIT=1 Q:SDQUIT
- I $D(^SCE(+$$EXAE^SDOE(DFN,CANDATE,CANDATE),0)) S SDQUIT=1 Q:SDQUIT
- ; future - try to locate index for the below line to properly kill it with fileman
- K ^DPT("ASDPSD","B",SDIV,CANDATE,DFN)
- Q
- ;
- EVT(DFN,SDTTM,SDSC,SDPL,SDCNHDL) ; -- separate tag if need to NEW vars
- ; -- cancel event
- N FR,I,SDTIME,DH,SC
- D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESCCAVAIL2 2227 printed Feb 19, 2025@00:22:33 Page 2
- SDESCCAVAIL2 ;ALB/BWF - VISTA SCHEDULING RPCS CANCEL CLINIC AVAILABILITY UTILITIES ; August 30, 2022
- +1 ;;5.3;Scheduling;**824**;Aug 13, 1993;Build 3
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 ;
- +4 ;
- +5 ;No Direct Call
- QUIT
- +6 ;
- COED(SDCL,SDBEG,SDEND,SDMSG) ; -- scan appts for those co'ed
- +1 NEW SDDA,SDATE,SD0,SDC,SDESC
- +2 SET SDESC=0
- SET SDATE=SDBEG-.0000001
- +3 FOR
- SET SDATE=$ORDER(^SC(SDCL,"S",SDATE))
- if 'SDATE!(SDATE>SDEND)
- QUIT
- Begin DoDot:1
- +4 SET SDDA=0
- FOR
- SET SDDA=$ORDER(^SC(SDCL,"S",SDATE,1,SDDA))
- if 'SDDA
- QUIT
- Begin DoDot:2
- +5 IF $$GET1^DIQ(44.003,SDDA_","_SDATE_","_SDCL_",",310,"I")="C"
- QUIT
- +6 IF $$GET1^DIQ(44.003,SDDA_","_SDATE_","_SDCL_",",303,"I")
- SET SDESC=1
- End DoDot:2
- End DoDot:1
- +7 QUIT SDESC
- +8 ;
- CHKOVERLAP(CANARY,FROM,TO) ;
- +1 NEW CHKDT,SDERR
- +2 SET (CHKDT,SDERR)=0
- +3 FOR
- SET CHKDT=$ORDER(CANARY(CHKDT))
- if 'CHKDT!(SDERR)
- QUIT
- Begin DoDot:1
- +4 SET SDERR=$SELECT(FROM'<CHKDT&(FROM<CANARY(CHKDT)):1,TO>CHKDT&(TO<CANARY(CHKDT)):1,1:0)
- if SDERR
- QUIT
- +5 IF CHKDT'<FROM&(CHKDT<TO)
- SET SDERR=1
- QUIT
- End DoDot:1
- +6 IF $GET(SDERR)
- QUIT 1
- +7 QUIT 0
- +8 ;
- TC(TIME,SD,STARTOFDAY,SI) ;
- +1 NEW %DT,X,Y,SDXX,FTIME,MSG
- +2 ; fix times less than 4 characters
- +3 SET FTIME=SD_"."_TIME
- +4 SET FTIME=$PIECE($$FMTE^XLFDT(FTIME,"T"),"@",2)
- +5 SET FTIME=$TRANSLATE(FTIME,":","")
- +6 SET X=$$FMTE^XLFDT(SD)_"@"_FTIME
- SET %DT="T"
- +7 DO ^%DT
- +8 IF Y<0!(X["?")
- QUIT ""
- +9 SET X=$EXTRACT($PIECE(Y_"0000",".",2),1,4)
- +10 SET SDXX=$EXTRACT(X,3,4)
- +11 SET SDXX=X\100-STARTOFDAY*SI+(SDXX*SI\60)*2
- +12 IF SDXX<0
- SET MSG="Day Starts at "_STARTOFDAY
- SET Y=-1
- +13 IF SDXX>72
- SET MSG="Day Ends prior to provided end time "_X
- SET Y=-1
- +14 QUIT X_U_Y_U_SDXX_U_$GET(MSG)
- +15 ;
- CK1(CANDTTM,DFN,SDIV) ;
- +1 NEW SDX,SD1,CANDATE,CANDATELOOP,SDQUIT,STATUS,CANDATE
- +2 SET SDQUIT=0
- +3 SET (CANDATELOOP,CANDATE)=$PIECE(CANDTTM,".")
- +4 FOR
- SET CANDATELOOP=$ORDER(^DPT(DFN,"S",CANDATELOOP))
- if 'CANDATELOOP!(CANDATELOOP'=CANDATE)
- QUIT
- Begin DoDot:1
- +5 SET STATUS=$$GET1^DIQ(2.98,CANDATELOOP_","_DFN_",",3,"I")
- +6 IF STATUS'["C"
- IF STATUS'["N"
- SET SDQUIT=1
- End DoDot:1
- +7 if SDQUIT
- QUIT
- +8 FOR SD1=2,4
- IF $DATA(^SC("AAS",CANDTTM,CANDATE,DFN))
- SET SDQUIT=1
- if SDQUIT
- QUIT
- +9 IF $DATA(^SCE(+$$EXAE^SDOE(DFN,CANDATE,CANDATE),0))
- SET SDQUIT=1
- if SDQUIT
- QUIT
- +10 ; future - try to locate index for the below line to properly kill it with fileman
- +11 KILL ^DPT("ASDPSD","B",SDIV,CANDATE,DFN)
- +12 QUIT
- +13 ;
- EVT(DFN,SDTTM,SDSC,SDPL,SDCNHDL) ; -- separate tag if need to NEW vars
- +1 ; -- cancel event
- +2 NEW FR,I,SDTIME,DH,SC
- +3 DO CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL)
- KILL SDATA,SDCNHDL
- +4 QUIT
- +5 ;
