SDESUTIL ;ALB/TAW,KML,LAB,MGD,ANU,MGD,ANU,BWF,TJB - SDES Utilities ;Aug 27, 2024
;;5.3;Scheduling;**801,804,805,814,816,818,820,823,824,825,831,836,838,845,851,877,878,887**;Aug 13, 1993;Build 7
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to INSTITUTION in #2251
; Reference to KERNEL SYSTEM PARAMETERS in #1518
; Reference to ^ECX(728.44 in #7340
Q
;
PADCLTIME(TIME) ;
; TIME - Time to Pad
S TIME=$S($G(TIME)'="":TIME,1:8)
I TIME'?1.2N Q -1
S TIME=TIME_"00"
Q TIME
;
PADFMTIME(TIME) ;
; TIME - Time to Pad
I TIME'?1.4N Q -1
S TIME=$E(TIME_"0000",1,4)
Q TIME
;
PADLENGTH(STRING,CHAR,LENGTH,WHERE) ;
N PAD,PADST
I $L(STRING)'<LENGTH Q STRING
S PADST=LENGTH-$L(STRING)
S $P(PAD,CHAR,PADST)=CHAR
I WHERE="F" S STRING=PAD_STRING
I WHERE="E" S STRING=STRING_PAD
Q STRING
;
EASVALIDATE(SDEAS) ;
I SDEAS="" S SDEAS=-1 Q SDEAS
S SDEAS=$$STRIP(SDEAS)
I $L(SDEAS)>40 S SDEAS=-1
Q SDEAS
;
STRIP(SDECZ) ;Replace control characters with spaces
N SDECI
F SDECI=1:1:$L(SDECZ) I (32>$A($E(SDECZ,SDECI))) S SDECZ=$E(SDECZ,1,SDECI-1)_" "_$E(SDECZ,SDECI+1,999)
Q SDECZ
;
ISDATEDST(DATE,DSTSUM) ;Does this date use Daylight Savings
; DATE - FM format
; DSTSUM - "DST" or "SUM"
; Return 1 = DATE is considered DST or SUM
; 0 = DATE is not DST and not SUM
; -1 = DATE is not FM format
N YR
S DATE=$G(DATE),DSTSUM=$G(DSTSUM)
I '$$VALIDFMFORMAT^SDECDATE(DATE) Q -1
S YR=$E(DATE,2,3)
I DATE<$$DSTSTART(YR,DSTSUM) Q 0
I DATE>$$DSTEND(YR,DSTSUM) Q 0
Q 1
DSTSTART(YR,DSTSUM) ;Daylight Savings or Summer start date
; countries that observe DST or Summer ST (e.g., USA observes DST and Europe observes SUM ST)
; YR - 2 digit year
; DSTSUM - "DST" or "SUM"
; Return is the FM date for the FIRST day of DST or SUM
N DSTMONTH,DOW,DSTDT,SUNDAY
S DSTMONTH="0301",DSTSUM=$G(DSTSUM)
; SUNDAY will be 2nd Sunday in March OR Last Sunday in March
S SUNDAY=$S(DSTSUM="DST":2,DSTSUM="SUM":"4,5",1:2) ;if not DST or SUM, treat as DST
S YR=$G(YR)
I YR="" S DSTDT=$E(DT,1,3)_DSTMONTH
E S DSTDT=$E(DT)_YR_DSTMONTH
S DOW=$$DOW^XLFDT(DSTDT,1)
I DOW D
.I DSTSUM="DST" S DSTDT=DSTDT+(SUNDAY*7)-DOW
.E S DSTDT=$$SUMMER(DSTDT,DOW,SUNDAY)
Q DSTDT
DSTEND(YR,DSTSUM) ;Daylight Savings END date
; YR - 2 digit year
; DSTSUM - "DST" or "SUM"
; Return is the FM date for the LAST day of DST or SUM
N DSTMONTH,DOW,DSTDT,SUNDAY
S DSTSUM=$G(DSTSUM)
S DSTMONTH=$S(DSTSUM="DST":"1101",DSTSUM="SUM":"1001",1:"1101")
; SUNDAY will be first Sunday in November or last Sunday in October
S SUNDAY=$S(DSTSUM="DST":1,DSTSUM="SUM":"4,5",1:1) ; if not DST or SUM treat as DST
S YR=$G(YR)
I YR="" S DSTDT=$E(DT,1,3)_DSTMONTH
E S DSTDT=$E(DT)_YR_DSTMONTH
S DOW=$$DOW^XLFDT(DSTDT,1)
I DOW D
.I DSTSUM="DST" S DSTDT=DSTDT+(SUNDAY*7)-DOW
.E S DSTDT=$$SUMMER(DSTDT,DOW,SUNDAY)
Q $$FMADD^XLFDT(DSTDT,-1)
;
SUMMER(DSTDT,DOW,SUNDAY) ; determine last Sunday of MARCH or OCTOBER
; DSTDT - March or October (e.g, CYY0301 or CYY1001)
; DOW - 1, 2, 3, 4, 5, or 6
; SUNDAY - "4,5" representing 4th or 5th Sunday of March or October
; Returns the date when SUMMER offset begins or ends (e.g., eastern Europe uses Summer offset)
N X,VALIDSUNDAY,LASTSUNDAY
S DSTDT=$G(DSTDT),DOW=$G(DOW),SUNDAY=$G(SUNDAY)
S LASTSUNDAY=0
F X=1,2 S VALIDSUNDAY=DSTDT+($P(SUNDAY,",",X)*7)-DOW I $$VALIDFMFORMAT^SDECDATE(VALIDSUNDAY) S LASTSUNDAY=VALIDSUNDAY
Q LASTSUNDAY
;
TIMEZONEDATA(CLINICIEN) ;Get timezone and offsets
; CLINIC - IEN from Hospital Location #44
; If clinic is not passed, use default Facility/Institution
; Output:
; Returns TimeZone Name ^ TimeZone IEN ^ TimeZone Exception ^ Offset for Standard Time ^ Offset for DST or SUMMER ^
N SDINST,SDDIV,SDTIMEZONEE,SDTIMEZONEI,TIMEZONEEXECPT,X,POP,TIMEFRAMEARY,OFFSET,OFFSETDSTSUM,DSTSUM,RETURN,TIMEFRAMEIEN,SDMSG
N EXECPTFLG
S (POP,SDINST,DSTSUM,EXECPTFLG)="",(OFFSET,OFFSETDSTSUM)=-9999
I $G(CLINICIEN) D
.S SDDIV=$$GET1^DIQ(44,CLINICIEN_",",3.5,"I")
.S:SDDIV SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I")
; 831 - BEGIN
I $$GET1^DIQ(4,SDINST,800,"I")="" S SDINST=""
; 831 - END
I SDINST="" S SDINST=$$GET1^DIQ(8989.3,1,217,"I")
S SDTIMEZONEE=$$GET1^DIQ(4,SDINST,800,"E")
S SDTIMEZONEI=$$GET1^DIQ(4,SDINST,800,"I")
S EXECPTFLG=$$GET1^DIQ(4,SDINST,802,"I")
S TIMEZONEEXECPT=$S(EXECPTFLG=0:1,1:0) ;if except value = 0 then exception is present
;
F X=1:1:3 D Q:POP
.S TIMEFRAMEIEN=X_","_SDTIMEZONEI_","
.D GETS^DIQ(1.711,TIMEFRAMEIEN,".01;.02","IE","TIMEFRAMEARY","SDMSG") ;Data from WORLD TIMEZONE file
.I '$D(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01)) S POP=1 Q
.I $G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="SST" S OFFSET=$G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E"))
.I $G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="DST" S DSTSUM="DST",OFFSETDSTSUM=$G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E")) ;vse-2705
.I $G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="SUM" S DSTSUM="SUM",OFFSETDSTSUM=$G(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E")) ;vse-2705
;
Q SDTIMEZONEE_"^"_SDTIMEZONEI_"^"_TIMEZONEEXECPT_"^"_OFFSET_"^"_OFFSETDSTSUM_"^"_DSTSUM ;vse-2705
;
GETTZOFFSET(SDDATE,SDCLINIC) ;Get Time Zone offset based on clinic and daylight savings
; SDCLINIC - OPT - IEN from Hospital Location #44
; SDDATE - REQ - FM formatted date
; Return
; If clinic is passed in get Division then Institution
; Otherwise get Institution from Kernel System Parameters
; Get the Time Zone and Time Zone Exception from the Institution
N OFFSET,TZINFO
S SDDATE=$G(SDDATE)
I '$$VALIDFMFORMAT^SDECDATE(SDDATE) Q ""
S SDCLINIC=$G(SDCLINIC)
S TZINFO=$$TIMEZONEDATA(SDCLINIC)
S OFFSET=$P(TZINFO,"^",4) ;assume non DST
; If the Institution uses DST or SUMMER & SDDATE is in the daylight savings period, then send the DST/SUMMER Offset
I $P(TZINFO,"^",3)=0 S OFFSET=$S($$ISDATEDST(SDDATE,$P(TZINFO,"^",6)):$P(TZINFO,"^",5),1:OFFSET)
Q OFFSET
;
CHAR4(CLINNAME) ;
; CLINNAME - REQ - Name of clinic from #44
; Return
; The CODE (#.01) field from NATIONAL CLINIC (#728.411) file or null
N IEN,NATLCODE
I CLINNAME="" Q ""
I '$D(^SC("B",CLINNAME)) Q ""
S IEN=$$FIND1^DIC(728.44,"","X",CLINNAME)
I 'IEN Q ""
S NATLCODE=$$GET1^DIQ(728.44,IEN_",",7,"E")
Q NATLCODE
;
TELEPHONE(PHONE) ; Format all numeric Telephone Number
; PHONE - The Telephone Number
; Return
; If PHONE is all numeric it will be formatted as follows
; 1234567890 will be formatted as (123)456-7890
; otherwise the passed in PHONE is returned.
S PHONE=$G(PHONE,"")
I PHONE?10N S PHONE="("_$E(PHONE,1,3)_")"_$E(PHONE,4,6)_"-"_$E(PHONE,7,10)
Q PHONE
;
EXT(EXT) ; Add an x to the beginning of an all numeric Telephone Extension field.
; EXT - The Telephone Extension.
; Return
; If EXT is all numeric, a lowercase x concantenated to the passed in EXT.
; otherwise the passed in EXT is returned.
S EXT=$G(EXT,"")
I EXT?1.N S EXT="x"_EXT
Q EXT
;
INACTIVE(SDCL,SDDT) ; determine if clinic is active
; Input:
; SDCL = (Req) IEN of Clinic from file #44.
; SDDT = (Opt) Date to use for determining Status. If not passed in, defaults to DT.
; Return:
; 0=ACTIVE
; 1=INACTIVE
Q $$INACTIVE^SDES2UTIL($G(SDCL),$G(SDDT))
;
STATIONNUMBER(CLINICIEN) ;
; Input:
; CLINICIEN (Opt) = IEN of the Clinic from File #44. If not passed in, the default
; Institution for the VistA Instance it used.
; Output: The STATION NUMBER (#99) field from the INSTITUTION (#4) file.
N DIVISION,INSTIEN,STATIONNUMBER
I $G(CLINICIEN)="" D Q STATIONNUMBER
. S STATIONNUMBER=$$KSP^XUPARAM("INST")_","
. S STATIONNUMBER=$$GET1^DIQ(4,STATIONNUMBER,99)
I +$G(CLINICIEN) D Q STATIONNUMBER
. S DIVISION=$$GET1^DIQ(44,CLINICIEN,3.5,"I")
. S INSTIEN=$$GET1^DIQ(40.8,DIVISION,.07,"I")
. S STATIONNUMBER=$$GET1^DIQ(4,INSTIEN,99,"I")
Q
;
VALIDATEAMIS(AMIS,RESTYP) ;
; Input:
; AMIS: The AMIS Stop Code to validate
; RESTYP: P:Primary, C:Credit
; Output:
; 0 = AMIS Stop Code is Valid
; # = Error number to log
S AMIS=$G(AMIS),RESTYP=$G(RESTYP)
N ERRORNUM
S ERRORNUM=""
I RESTYP="P" D PRIMARYAMIS(.AMIS,.ERRORNUM)
I RESTYP="C" D SECONDARYAMIS(.AMIS,.ERRORNUM)
Q +ERRORNUM
;
PRIMARYAMIS(PRIAMIS,ERRORNUM) ;
I +PRIAMIS=0 S ERRORNUM=270 Q
I $L(PRIAMIS) D
. I +PRIAMIS=0 S ERRORNUM=270 Q
. I +PRIAMIS=900 S ERRORNUM=273 Q
. S PRIAMIS=$$AMISTOSTOPCODE(.PRIAMIS)
. I +PRIAMIS=0 S ERRORNUM=270 Q
. ; AMIS Stop Code has priority over passed in Stop Code
. I $$RESCHKFAILED(+PRIAMIS,"P") S ERRORNUM=287 Q
Q
;
SECONDARYAMIS(CREDITAMIS,ERRORNUM) ;
I +CREDITAMIS=0 S ERRORNUM=271 Q
I $L(CREDITAMIS) D
. I +CREDITAMIS=0 S ERRORNUM=271 Q
. I +CREDITAMIS=900 S ERRORNUM=273 Q
. S CREDITAMIS=$$AMISTOSTOPCODE(.CREDITAMIS)
. I +CREDITAMIS=0 S ERRORNUM=271 Q
. ; AMIS Credit Stop Code has priority over passed in Credit Stop Code
. I $$RESCHKFAILED(+CREDITAMIS,"S") S ERRORNUM=288 Q
Q
;
AMISTOSTOPCODE(AMIS) ; Map from AMIS to Stop Code
; Input: AMIS = (Req) the AMIS REPORTING STOP CODE (#1) field from the CLINIC STOP (#40.7) file.
; Output: 0:validation failed, IEN for the Stop Code that matches to the passed in AMIS code.
N STOPIEN,STOPINACTDT,STOPCOUNT,STOPFOUND
I '$G(AMIS) Q 0
S (STOPIEN,STOPCOUNT,STOPFOUND)=0
F S STOPIEN=$O(^DIC(40.7,"C",AMIS,STOPIEN)) Q:'STOPIEN D
.S STOPINACTDT=$$GET1^DIQ(40.7,STOPIEN,2,"I")
.I STOPINACTDT,STOPINACTDT<DT!(STOPINACTDT=DT) Q
.S STOPCOUNT=STOPCOUNT+1
.S STOPFOUND=STOPIEN
I STOPCOUNT>1 Q 0
Q STOPFOUND
;
STOPCODETOAMIS(STOPIEN) ; Map from Stop Code IEN to AMIS Stop Code Number
; Input: STOPIEN = (Req) The IEN of the Stop Code in the CLINIC STOP (#40.7) file.
; Output: "": validation failed, IEN for the AMIS REPORTING STOP CODE (#1).
N STOPCODE
S STOPCODE="",STOPIEN=$G(STOPIEN,"")
Q:STOPIEN<1 STOPCODE
Q:'$D(^DIC(40.7,STOPIEN,0)) STOPCODE
S STOPCODE=$$GET1^DIQ(40.7,STOPIEN,1,"I")
Q STOPCODE
;
RESCHKFAILED(STOPCODEIEN,RESTYPE) ;
; Input: STOPCODEIEN (Req) IEN from CLINIC STOP (#40.7) file.
; RESTYPE (Req) P for Primary or S for Credit
; Output: 0: Restriction checks passed, 1: Restriction checks failed
I '+STOPCODEIEN Q 1
I "^P^S^"'[("^"_RESTYPE_"^") Q 1
N RESTRICTION
S RESTRICTION=$$GET1^DIQ(40.7,STOPCODEIEN,5,"I")
I RESTRICTION="E" Q 0
I RESTRICTION'=RESTYPE Q 1
Q 0
; Set of codes internal to external
SOCINT2EXT(FILE,FLD,INTVAL) ;
N FOUND,ITEM,CODE,EXTCODE,RETURN,INTCODE,RESULTS
I '$L($G(INTVAL)) Q ""
S INTVAL=$$UP^XLFSTR(INTVAL)
D FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
S FOUND=0
F ITEM=1:1:$L(RESULTS("SET OF CODES"),";") D Q:FOUND
.S CODE=$P(RESULTS("SET OF CODES"),";",ITEM) Q:'$L(CODE)
.S INTCODE=$P(CODE,":"),EXTCODE=$P(CODE,":",2)
.I INTVAL=INTCODE S RETURN=EXTCODE,FOUND=1
Q $G(RETURN)
; Set of codes external to internal
SOCEXT2INT(FILE,FLD,EXTVAL) ;
N FOUND,ITEM,CODE,EXTCODE,RETURN,INTCODE,RESULTS
I '$L($G(EXTVAL)) Q ""
S EXTVAL=$$UP^XLFSTR(EXTVAL)
D FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
S FOUND=0
F ITEM=1:1:$L(RESULTS("SET OF CODES"),";") D Q:FOUND
.S CODE=$P(RESULTS("SET OF CODES"),";",ITEM) Q:'$L(CODE)
.S INTCODE=$P(CODE,":"),EXTCODE=$P(CODE,":",2)
.I EXTCODE=EXTVAL S RETURN=INTCODE,FOUND=1
Q $G(RETURN)
;
INCREMENTAVAIL1(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ;
N COUNT,CLINICAPPTLENGTH,NUMOFSLOTSINPLAY
S CLINICAPPTLENGTH=+$E($$GET1^DIQ(44,CLINICIEN,1917,"E"),1,2)
S NUMOFSLOTSINPLAY=APPTLENGTH/CLINICAPPTLENGTH
F COUNT=1:1:NUMOFSLOTSINPLAY D
.I COUNT>1 D
..S APPTSTARTTIME=$$FMADD^XLFDT(APPTSTARTTIME,,,CLINICAPPTLENGTH)
.D INCREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH)
Q
;
INCREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ; increment availability by 1 in cancelled slot
N SLOTSTATUSSTRING,SLOTINCREMENT,CURRENTSCHEDULE,NEWSCHEDULE,TIMECLINICOPENS,SLOTLENGTH,NEWAVAILABILITY,SPECIALCHARACTER,AVAILABILITYFDA,CENTEROFSLOT,CHARMULTIPLIER
;
S SLOTSTATUSSTRING="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
S CURRENTSCHEDULE=$$GET1^DIQ(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)
S TIMECLINICOPENS=$S($L($$GET1^DIQ(44,CLINICIEN,1914,"I")):$$GET1^DIQ(44,CLINICIEN,1914,"I"),1:8)-1/100
S SLOTLENGTH=$S($$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
S SLOTINCREMENT=$S('$$GET1^DIQ(44,CLINICIEN,1917,"I"):4,$$GET1^DIQ(44,CLINICIEN,1917,"I")<3:4,$$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
S CHARMULTIPLIER=$S(SLOTLENGTH<3:8/SLOTLENGTH,1:2)
S NEWAVAILABILITY=APPTSTARTTIME#1-TIMECLINICOPENS*100
S CENTEROFSLOT=NEWAVAILABILITY#1*SLOTINCREMENT\.6+(NEWAVAILABILITY\1*SLOTINCREMENT)*2
;
I $G(NEWAVAILABILITY) D
.F SPECIALCHARACTER=CENTEROFSLOT:CHARMULTIPLIER Q:$L($G(NEWSCHEDULE))!($G(NEWAVAILABILITY)="") D
..S NEWAVAILABILITY=$E(SLOTSTATUSSTRING,$F(SLOTSTATUSSTRING,$E(CURRENTSCHEDULE,SPECIALCHARACTER+1)))
..S NEWSCHEDULE=$E(CURRENTSCHEDULE,1,SPECIALCHARACTER)_NEWAVAILABILITY_$E(CURRENTSCHEDULE,SPECIALCHARACTER+2,999)
;
;877 - If new schedule is not asssigned, don't use it and file it
;
;S AVAILABILITYFDA(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)=NEWSCHEDULE
;D FILE^DIE(,"AVAILABILITYFDA") K AVAILABILITYFDA
I $L($G(NEWSCHEDULE)) D
.S AVAILABILITYFDA(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)=NEWSCHEDULE
.D FILE^DIE(,"AVAILABILITYFDA")
K AVAILABILITYFDA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDESUTIL 13497 printed Oct 16, 2024@18:58:15 Page 2
SDESUTIL ;ALB/TAW,KML,LAB,MGD,ANU,MGD,ANU,BWF,TJB - SDES Utilities ;Aug 27, 2024
+1 ;;5.3;Scheduling;**801,804,805,814,816,818,820,823,824,825,831,836,838,845,851,877,878,887**;Aug 13, 1993;Build 7
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to INSTITUTION in #2251
+5 ; Reference to KERNEL SYSTEM PARAMETERS in #1518
+6 ; Reference to ^ECX(728.44 in #7340
+7 QUIT
+8 ;
PADCLTIME(TIME) ;
+1 ; TIME - Time to Pad
+2 SET TIME=$SELECT($GET(TIME)'="":TIME,1:8)
+3 IF TIME'?1.2N
QUIT -1
+4 SET TIME=TIME_"00"
+5 QUIT TIME
+6 ;
PADFMTIME(TIME) ;
+1 ; TIME - Time to Pad
+2 IF TIME'?1.4N
QUIT -1
+3 SET TIME=$EXTRACT(TIME_"0000",1,4)
+4 QUIT TIME
+5 ;
PADLENGTH(STRING,CHAR,LENGTH,WHERE) ;
+1 NEW PAD,PADST
+2 IF $LENGTH(STRING)'<LENGTH
QUIT STRING
+3 SET PADST=LENGTH-$LENGTH(STRING)
+4 SET $PIECE(PAD,CHAR,PADST)=CHAR
+5 IF WHERE="F"
SET STRING=PAD_STRING
+6 IF WHERE="E"
SET STRING=STRING_PAD
+7 QUIT STRING
+8 ;
EASVALIDATE(SDEAS) ;
+1 IF SDEAS=""
SET SDEAS=-1
QUIT SDEAS
+2 SET SDEAS=$$STRIP(SDEAS)
+3 IF $LENGTH(SDEAS)>40
SET SDEAS=-1
+4 QUIT SDEAS
+5 ;
STRIP(SDECZ) ;Replace control characters with spaces
+1 NEW SDECI
+2 FOR SDECI=1:1:$LENGTH(SDECZ)
IF (32>$ASCII($EXTRACT(SDECZ,SDECI)))
SET SDECZ=$EXTRACT(SDECZ,1,SDECI-1)_" "_$EXTRACT(SDECZ,SDECI+1,999)
+3 QUIT SDECZ
+4 ;
ISDATEDST(DATE,DSTSUM) ;Does this date use Daylight Savings
+1 ; DATE - FM format
+2 ; DSTSUM - "DST" or "SUM"
+3 ; Return 1 = DATE is considered DST or SUM
+4 ; 0 = DATE is not DST and not SUM
+5 ; -1 = DATE is not FM format
+6 NEW YR
+7 SET DATE=$GET(DATE)
SET DSTSUM=$GET(DSTSUM)
+8 IF '$$VALIDFMFORMAT^SDECDATE(DATE)
QUIT -1
+9 SET YR=$EXTRACT(DATE,2,3)
+10 IF DATE<$$DSTSTART(YR,DSTSUM)
QUIT 0
+11 IF DATE>$$DSTEND(YR,DSTSUM)
QUIT 0
+12 QUIT 1
DSTSTART(YR,DSTSUM) ;Daylight Savings or Summer start date
+1 ; countries that observe DST or Summer ST (e.g., USA observes DST and Europe observes SUM ST)
+2 ; YR - 2 digit year
+3 ; DSTSUM - "DST" or "SUM"
+4 ; Return is the FM date for the FIRST day of DST or SUM
+5 NEW DSTMONTH,DOW,DSTDT,SUNDAY
+6 SET DSTMONTH="0301"
SET DSTSUM=$GET(DSTSUM)
+7 ; SUNDAY will be 2nd Sunday in March OR Last Sunday in March
+8 ;if not DST or SUM, treat as DST
SET SUNDAY=$SELECT(DSTSUM="DST":2,DSTSUM="SUM":"4,5",1:2)
+9 SET YR=$GET(YR)
+10 IF YR=""
SET DSTDT=$EXTRACT(DT,1,3)_DSTMONTH
+11 IF '$TEST
SET DSTDT=$EXTRACT(DT)_YR_DSTMONTH
+12 SET DOW=$$DOW^XLFDT(DSTDT,1)
+13 IF DOW
Begin DoDot:1
+14 IF DSTSUM="DST"
SET DSTDT=DSTDT+(SUNDAY*7)-DOW
+15 IF '$TEST
SET DSTDT=$$SUMMER(DSTDT,DOW,SUNDAY)
End DoDot:1
+16 QUIT DSTDT
DSTEND(YR,DSTSUM) ;Daylight Savings END date
+1 ; YR - 2 digit year
+2 ; DSTSUM - "DST" or "SUM"
+3 ; Return is the FM date for the LAST day of DST or SUM
+4 NEW DSTMONTH,DOW,DSTDT,SUNDAY
+5 SET DSTSUM=$GET(DSTSUM)
+6 SET DSTMONTH=$SELECT(DSTSUM="DST":"1101",DSTSUM="SUM":"1001",1:"1101")
+7 ; SUNDAY will be first Sunday in November or last Sunday in October
+8 ; if not DST or SUM treat as DST
SET SUNDAY=$SELECT(DSTSUM="DST":1,DSTSUM="SUM":"4,5",1:1)
+9 SET YR=$GET(YR)
+10 IF YR=""
SET DSTDT=$EXTRACT(DT,1,3)_DSTMONTH
+11 IF '$TEST
SET DSTDT=$EXTRACT(DT)_YR_DSTMONTH
+12 SET DOW=$$DOW^XLFDT(DSTDT,1)
+13 IF DOW
Begin DoDot:1
+14 IF DSTSUM="DST"
SET DSTDT=DSTDT+(SUNDAY*7)-DOW
+15 IF '$TEST
SET DSTDT=$$SUMMER(DSTDT,DOW,SUNDAY)
End DoDot:1
+16 QUIT $$FMADD^XLFDT(DSTDT,-1)
+17 ;
SUMMER(DSTDT,DOW,SUNDAY) ; determine last Sunday of MARCH or OCTOBER
+1 ; DSTDT - March or October (e.g, CYY0301 or CYY1001)
+2 ; DOW - 1, 2, 3, 4, 5, or 6
+3 ; SUNDAY - "4,5" representing 4th or 5th Sunday of March or October
+4 ; Returns the date when SUMMER offset begins or ends (e.g., eastern Europe uses Summer offset)
+5 NEW X,VALIDSUNDAY,LASTSUNDAY
+6 SET DSTDT=$GET(DSTDT)
SET DOW=$GET(DOW)
SET SUNDAY=$GET(SUNDAY)
+7 SET LASTSUNDAY=0
+8 FOR X=1,2
SET VALIDSUNDAY=DSTDT+($PIECE(SUNDAY,",",X)*7)-DOW
IF $$VALIDFMFORMAT^SDECDATE(VALIDSUNDAY)
SET LASTSUNDAY=VALIDSUNDAY
+9 QUIT LASTSUNDAY
+10 ;
TIMEZONEDATA(CLINICIEN) ;Get timezone and offsets
+1 ; CLINIC - IEN from Hospital Location #44
+2 ; If clinic is not passed, use default Facility/Institution
+3 ; Output:
+4 ; Returns TimeZone Name ^ TimeZone IEN ^ TimeZone Exception ^ Offset for Standard Time ^ Offset for DST or SUMMER ^
+5 NEW SDINST,SDDIV,SDTIMEZONEE,SDTIMEZONEI,TIMEZONEEXECPT,X,POP,TIMEFRAMEARY,OFFSET,OFFSETDSTSUM,DSTSUM,RETURN,TIMEFRAMEIEN,SDMSG
+6 NEW EXECPTFLG
+7 SET (POP,SDINST,DSTSUM,EXECPTFLG)=""
SET (OFFSET,OFFSETDSTSUM)=-9999
+8 IF $GET(CLINICIEN)
Begin DoDot:1
+9 SET SDDIV=$$GET1^DIQ(44,CLINICIEN_",",3.5,"I")
+10 if SDDIV
SET SDINST=$$GET1^DIQ(40.8,SDDIV_",",.07,"I")
End DoDot:1
+11 ; 831 - BEGIN
+12 IF $$GET1^DIQ(4,SDINST,800,"I")=""
SET SDINST=""
+13 ; 831 - END
+14 IF SDINST=""
SET SDINST=$$GET1^DIQ(8989.3,1,217,"I")
+15 SET SDTIMEZONEE=$$GET1^DIQ(4,SDINST,800,"E")
+16 SET SDTIMEZONEI=$$GET1^DIQ(4,SDINST,800,"I")
+17 SET EXECPTFLG=$$GET1^DIQ(4,SDINST,802,"I")
+18 ;if except value = 0 then exception is present
SET TIMEZONEEXECPT=$SELECT(EXECPTFLG=0:1,1:0)
+19 ;
+20 FOR X=1:1:3
Begin DoDot:1
+21 SET TIMEFRAMEIEN=X_","_SDTIMEZONEI_","
+22 ;Data from WORLD TIMEZONE file
DO GETS^DIQ(1.711,TIMEFRAMEIEN,".01;.02","IE","TIMEFRAMEARY","SDMSG")
+23 IF '$DATA(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01))
SET POP=1
QUIT
+24 IF $GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="SST"
SET OFFSET=$GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E"))
+25 ;vse-2705
IF $GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="DST"
SET DSTSUM="DST"
SET OFFSETDSTSUM=$GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E"))
+26 ;vse-2705
IF $GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.01,"I"))="SUM"
SET DSTSUM="SUM"
SET OFFSETDSTSUM=$GET(TIMEFRAMEARY(1.711,TIMEFRAMEIEN,.02,"E"))
End DoDot:1
if POP
QUIT
+27 ;
+28 ;vse-2705
QUIT SDTIMEZONEE_"^"_SDTIMEZONEI_"^"_TIMEZONEEXECPT_"^"_OFFSET_"^"_OFFSETDSTSUM_"^"_DSTSUM
+29 ;
GETTZOFFSET(SDDATE,SDCLINIC) ;Get Time Zone offset based on clinic and daylight savings
+1 ; SDCLINIC - OPT - IEN from Hospital Location #44
+2 ; SDDATE - REQ - FM formatted date
+3 ; Return
+4 ; If clinic is passed in get Division then Institution
+5 ; Otherwise get Institution from Kernel System Parameters
+6 ; Get the Time Zone and Time Zone Exception from the Institution
+7 NEW OFFSET,TZINFO
+8 SET SDDATE=$GET(SDDATE)
+9 IF '$$VALIDFMFORMAT^SDECDATE(SDDATE)
QUIT ""
+10 SET SDCLINIC=$GET(SDCLINIC)
+11 SET TZINFO=$$TIMEZONEDATA(SDCLINIC)
+12 ;assume non DST
SET OFFSET=$PIECE(TZINFO,"^",4)
+13 ; If the Institution uses DST or SUMMER & SDDATE is in the daylight savings period, then send the DST/SUMMER Offset
+14 IF $PIECE(TZINFO,"^",3)=0
SET OFFSET=$SELECT($$ISDATEDST(SDDATE,$PIECE(TZINFO,"^",6)):$PIECE(TZINFO,"^",5),1:OFFSET)
+15 QUIT OFFSET
+16 ;
CHAR4(CLINNAME) ;
+1 ; CLINNAME - REQ - Name of clinic from #44
+2 ; Return
+3 ; The CODE (#.01) field from NATIONAL CLINIC (#728.411) file or null
+4 NEW IEN,NATLCODE
+5 IF CLINNAME=""
QUIT ""
+6 IF '$DATA(^SC("B",CLINNAME))
QUIT ""
+7 SET IEN=$$FIND1^DIC(728.44,"","X",CLINNAME)
+8 IF 'IEN
QUIT ""
+9 SET NATLCODE=$$GET1^DIQ(728.44,IEN_",",7,"E")
+10 QUIT NATLCODE
+11 ;
TELEPHONE(PHONE) ; Format all numeric Telephone Number
+1 ; PHONE - The Telephone Number
+2 ; Return
+3 ; If PHONE is all numeric it will be formatted as follows
+4 ; 1234567890 will be formatted as (123)456-7890
+5 ; otherwise the passed in PHONE is returned.
+6 SET PHONE=$GET(PHONE,"")
+7 IF PHONE?10N
SET PHONE="("_$EXTRACT(PHONE,1,3)_")"_$EXTRACT(PHONE,4,6)_"-"_$EXTRACT(PHONE,7,10)
+8 QUIT PHONE
+9 ;
EXT(EXT) ; Add an x to the beginning of an all numeric Telephone Extension field.
+1 ; EXT - The Telephone Extension.
+2 ; Return
+3 ; If EXT is all numeric, a lowercase x concantenated to the passed in EXT.
+4 ; otherwise the passed in EXT is returned.
+5 SET EXT=$GET(EXT,"")
+6 IF EXT?1.N
SET EXT="x"_EXT
+7 QUIT EXT
+8 ;
INACTIVE(SDCL,SDDT) ; determine if clinic is active
+1 ; Input:
+2 ; SDCL = (Req) IEN of Clinic from file #44.
+3 ; SDDT = (Opt) Date to use for determining Status. If not passed in, defaults to DT.
+4 ; Return:
+5 ; 0=ACTIVE
+6 ; 1=INACTIVE
+7 QUIT $$INACTIVE^SDES2UTIL($GET(SDCL),$GET(SDDT))
+8 ;
STATIONNUMBER(CLINICIEN) ;
+1 ; Input:
+2 ; CLINICIEN (Opt) = IEN of the Clinic from File #44. If not passed in, the default
+3 ; Institution for the VistA Instance it used.
+4 ; Output: The STATION NUMBER (#99) field from the INSTITUTION (#4) file.
+5 NEW DIVISION,INSTIEN,STATIONNUMBER
+6 IF $GET(CLINICIEN)=""
Begin DoDot:1
+7 SET STATIONNUMBER=$$KSP^XUPARAM("INST")_","
+8 SET STATIONNUMBER=$$GET1^DIQ(4,STATIONNUMBER,99)
End DoDot:1
QUIT STATIONNUMBER
+9 IF +$GET(CLINICIEN)
Begin DoDot:1
+10 SET DIVISION=$$GET1^DIQ(44,CLINICIEN,3.5,"I")
+11 SET INSTIEN=$$GET1^DIQ(40.8,DIVISION,.07,"I")
+12 SET STATIONNUMBER=$$GET1^DIQ(4,INSTIEN,99,"I")
End DoDot:1
QUIT STATIONNUMBER
+13 QUIT
+14 ;
VALIDATEAMIS(AMIS,RESTYP) ;
+1 ; Input:
+2 ; AMIS: The AMIS Stop Code to validate
+3 ; RESTYP: P:Primary, C:Credit
+4 ; Output:
+5 ; 0 = AMIS Stop Code is Valid
+6 ; # = Error number to log
+7 SET AMIS=$GET(AMIS)
SET RESTYP=$GET(RESTYP)
+8 NEW ERRORNUM
+9 SET ERRORNUM=""
+10 IF RESTYP="P"
DO PRIMARYAMIS(.AMIS,.ERRORNUM)
+11 IF RESTYP="C"
DO SECONDARYAMIS(.AMIS,.ERRORNUM)
+12 QUIT +ERRORNUM
+13 ;
PRIMARYAMIS(PRIAMIS,ERRORNUM) ;
+1 IF +PRIAMIS=0
SET ERRORNUM=270
QUIT
+2 IF $LENGTH(PRIAMIS)
Begin DoDot:1
+3 IF +PRIAMIS=0
SET ERRORNUM=270
QUIT
+4 IF +PRIAMIS=900
SET ERRORNUM=273
QUIT
+5 SET PRIAMIS=$$AMISTOSTOPCODE(.PRIAMIS)
+6 IF +PRIAMIS=0
SET ERRORNUM=270
QUIT
+7 ; AMIS Stop Code has priority over passed in Stop Code
+8 IF $$RESCHKFAILED(+PRIAMIS,"P")
SET ERRORNUM=287
QUIT
End DoDot:1
+9 QUIT
+10 ;
SECONDARYAMIS(CREDITAMIS,ERRORNUM) ;
+1 IF +CREDITAMIS=0
SET ERRORNUM=271
QUIT
+2 IF $LENGTH(CREDITAMIS)
Begin DoDot:1
+3 IF +CREDITAMIS=0
SET ERRORNUM=271
QUIT
+4 IF +CREDITAMIS=900
SET ERRORNUM=273
QUIT
+5 SET CREDITAMIS=$$AMISTOSTOPCODE(.CREDITAMIS)
+6 IF +CREDITAMIS=0
SET ERRORNUM=271
QUIT
+7 ; AMIS Credit Stop Code has priority over passed in Credit Stop Code
+8 IF $$RESCHKFAILED(+CREDITAMIS,"S")
SET ERRORNUM=288
QUIT
End DoDot:1
+9 QUIT
+10 ;
AMISTOSTOPCODE(AMIS) ; Map from AMIS to Stop Code
+1 ; Input: AMIS = (Req) the AMIS REPORTING STOP CODE (#1) field from the CLINIC STOP (#40.7) file.
+2 ; Output: 0:validation failed, IEN for the Stop Code that matches to the passed in AMIS code.
+3 NEW STOPIEN,STOPINACTDT,STOPCOUNT,STOPFOUND
+4 IF '$GET(AMIS)
QUIT 0
+5 SET (STOPIEN,STOPCOUNT,STOPFOUND)=0
+6 FOR
SET STOPIEN=$ORDER(^DIC(40.7,"C",AMIS,STOPIEN))
if 'STOPIEN
QUIT
Begin DoDot:1
+7 SET STOPINACTDT=$$GET1^DIQ(40.7,STOPIEN,2,"I")
+8 IF STOPINACTDT
IF STOPINACTDT<DT!(STOPINACTDT=DT)
QUIT
+9 SET STOPCOUNT=STOPCOUNT+1
+10 SET STOPFOUND=STOPIEN
End DoDot:1
+11 IF STOPCOUNT>1
QUIT 0
+12 QUIT STOPFOUND
+13 ;
STOPCODETOAMIS(STOPIEN) ; Map from Stop Code IEN to AMIS Stop Code Number
+1 ; Input: STOPIEN = (Req) The IEN of the Stop Code in the CLINIC STOP (#40.7) file.
+2 ; Output: "": validation failed, IEN for the AMIS REPORTING STOP CODE (#1).
+3 NEW STOPCODE
+4 SET STOPCODE=""
SET STOPIEN=$GET(STOPIEN,"")
+5 if STOPIEN<1
QUIT STOPCODE
+6 if '$DATA(^DIC(40.7,STOPIEN,0))
QUIT STOPCODE
+7 SET STOPCODE=$$GET1^DIQ(40.7,STOPIEN,1,"I")
+8 QUIT STOPCODE
+9 ;
RESCHKFAILED(STOPCODEIEN,RESTYPE) ;
+1 ; Input: STOPCODEIEN (Req) IEN from CLINIC STOP (#40.7) file.
+2 ; RESTYPE (Req) P for Primary or S for Credit
+3 ; Output: 0: Restriction checks passed, 1: Restriction checks failed
+4 IF '+STOPCODEIEN
QUIT 1
+5 IF "^P^S^"'[("^"_RESTYPE_"^")
QUIT 1
+6 NEW RESTRICTION
+7 SET RESTRICTION=$$GET1^DIQ(40.7,STOPCODEIEN,5,"I")
+8 IF RESTRICTION="E"
QUIT 0
+9 IF RESTRICTION'=RESTYPE
QUIT 1
+10 QUIT 0
+11 ; Set of codes internal to external
SOCINT2EXT(FILE,FLD,INTVAL) ;
+1 NEW FOUND,ITEM,CODE,EXTCODE,RETURN,INTCODE,RESULTS
+2 IF '$LENGTH($GET(INTVAL))
QUIT ""
+3 SET INTVAL=$$UP^XLFSTR(INTVAL)
+4 DO FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
+5 SET FOUND=0
+6 FOR ITEM=1:1:$LENGTH(RESULTS("SET OF CODES"),";")
Begin DoDot:1
+7 SET CODE=$PIECE(RESULTS("SET OF CODES"),";",ITEM)
if '$LENGTH(CODE)
QUIT
+8 SET INTCODE=$PIECE(CODE,":")
SET EXTCODE=$PIECE(CODE,":",2)
+9 IF INTVAL=INTCODE
SET RETURN=EXTCODE
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+10 QUIT $GET(RETURN)
+11 ; Set of codes external to internal
SOCEXT2INT(FILE,FLD,EXTVAL) ;
+1 NEW FOUND,ITEM,CODE,EXTCODE,RETURN,INTCODE,RESULTS
+2 IF '$LENGTH($GET(EXTVAL))
QUIT ""
+3 SET EXTVAL=$$UP^XLFSTR(EXTVAL)
+4 DO FIELD^DID(FILE,FLD,"","SET OF CODES","RESULTS")
+5 SET FOUND=0
+6 FOR ITEM=1:1:$LENGTH(RESULTS("SET OF CODES"),";")
Begin DoDot:1
+7 SET CODE=$PIECE(RESULTS("SET OF CODES"),";",ITEM)
if '$LENGTH(CODE)
QUIT
+8 SET INTCODE=$PIECE(CODE,":")
SET EXTCODE=$PIECE(CODE,":",2)
+9 IF EXTCODE=EXTVAL
SET RETURN=INTCODE
SET FOUND=1
End DoDot:1
if FOUND
QUIT
+10 QUIT $GET(RETURN)
+11 ;
INCREMENTAVAIL1(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ;
+1 NEW COUNT,CLINICAPPTLENGTH,NUMOFSLOTSINPLAY
+2 SET CLINICAPPTLENGTH=+$EXTRACT($$GET1^DIQ(44,CLINICIEN,1917,"E"),1,2)
+3 SET NUMOFSLOTSINPLAY=APPTLENGTH/CLINICAPPTLENGTH
+4 FOR COUNT=1:1:NUMOFSLOTSINPLAY
Begin DoDot:1
+5 IF COUNT>1
Begin DoDot:2
+6 SET APPTSTARTTIME=$$FMADD^XLFDT(APPTSTARTTIME,,,CLINICAPPTLENGTH)
End DoDot:2
+7 DO INCREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH)
End DoDot:1
+8 QUIT
+9 ;
INCREMENTAVAIL2(CLINICIEN,APPTSTARTTIME,APPTLENGTH) ; increment availability by 1 in cancelled slot
+1 NEW SLOTSTATUSSTRING,SLOTINCREMENT,CURRENTSCHEDULE,NEWSCHEDULE,TIMECLINICOPENS,SLOTLENGTH,NEWAVAILABILITY,SPECIALCHARACTER,AVAILABILITYFDA,CENTEROFSLOT,CHARMULTIPLIER
+2 ;
+3 SET SLOTSTATUSSTRING="#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz"
+4 SET CURRENTSCHEDULE=$$GET1^DIQ(44.005,$PIECE(APPTSTARTTIME,".")_","_CLINICIEN_",",1)
+5 SET TIMECLINICOPENS=$SELECT($LENGTH($$GET1^DIQ(44,CLINICIEN,1914,"I")):$$GET1^DIQ(44,CLINICIEN,1914,"I"),1:8)-1/100
+6 SET SLOTLENGTH=$SELECT($$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
+7 SET SLOTINCREMENT=$SELECT('$$GET1^DIQ(44,CLINICIEN,1917,"I"):4,$$GET1^DIQ(44,CLINICIEN,1917,"I")<3:4,$$GET1^DIQ(44,CLINICIEN,1917,"I"):$$GET1^DIQ(44,CLINICIEN,1917,"I"),1:4)
+8 SET CHARMULTIPLIER=$SELECT(SLOTLENGTH<3:8/SLOTLENGTH,1:2)
+9 SET NEWAVAILABILITY=APPTSTARTTIME#1-TIMECLINICOPENS*100
+10 SET CENTEROFSLOT=NEWAVAILABILITY#1*SLOTINCREMENT\.6+(NEWAVAILABILITY\1*SLOTINCREMENT)*2
+11 ;
+12 IF $GET(NEWAVAILABILITY)
Begin DoDot:1
+13 FOR SPECIALCHARACTER=CENTEROFSLOT:CHARMULTIPLIER
if $LENGTH($GET(NEWSCHEDULE))!($GET(NEWAVAILABILITY)="")
QUIT
Begin DoDot:2
+14 SET NEWAVAILABILITY=$EXTRACT(SLOTSTATUSSTRING,$FIND(SLOTSTATUSSTRING,$EXTRACT(CURRENTSCHEDULE,SPECIALCHARACTER+1)))
+15 SET NEWSCHEDULE=$EXTRACT(CURRENTSCHEDULE,1,SPECIALCHARACTER)_NEWAVAILABILITY_$EXTRACT(CURRENTSCHEDULE,SPECIALCHARACTER+2,999)
End DoDot:2
End DoDot:1
+16 ;
+17 ;877 - If new schedule is not asssigned, don't use it and file it
+18 ;
+19 ;S AVAILABILITYFDA(44.005,$P(APPTSTARTTIME,".")_","_CLINICIEN_",",1)=NEWSCHEDULE
+20 ;D FILE^DIE(,"AVAILABILITYFDA") K AVAILABILITYFDA
+21 IF $LENGTH($GET(NEWSCHEDULE))
Begin DoDot:1
+22 SET AVAILABILITYFDA(44.005,$PIECE(APPTSTARTTIME,".")_","_CLINICIEN_",",1)=NEWSCHEDULE
+23 DO FILE^DIE(,"AVAILABILITYFDA")
End DoDot:1
+24 KILL AVAILABILITYFDA
+25 QUIT
+26 ;
