Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCAPU1

SCAPU1.m

Go to the documentation of this file.
  1. SCAPU1 ;ALB/REW,HPE/ART - TEAM API UTILITIES ; 9/17/09 4:30pm ;07/06/2017
  1. ;;5.3;Scheduling;**41,504,666**;AUG 13, 1993;Build 4
  1. ;;1.0
  1. Q
  1. ;
  1. DTCHK2(SCDATES,ACTDT,INACTDT) ;given scdates array was it active?
  1. N SCBEGIN,SCEND,SCINCL
  1. D INIT^SCAPMCU1(1) ;set default array
  1. Q $$DTCHK(SCBEGIN,SCEND,SCINCL,ACTDT,.INACTDT)
  1. ;
  1. DTCHK(BEGINDT,ENDDT,INCL,ACTDT,INACTDT) ; -- given activation/inactivation dates and begin & end dates and include flag was it active?
  1. ;Parameters:
  1. ; BEGINDT - begining date
  1. ; ENDDT - ending date
  1. ; INCL - 1= must be active for whole period to get a 'yes'/0 o/w
  1. ; ACTDT - activation date for record
  1. ; INACTDT - inactivation date for record
  1. ; returns: 1 = Active
  1. ; 0 = Inactive
  1. ; -1 = Error
  1. ;
  1. N OK
  1. S OK=-1
  1. G DTCHKQ:'$G(BEGINDT)!('$G(ENDDT))!('$G(ACTDT))
  1. S OK=0
  1. ;
  1. ;check date params for timestamp, strip time if all date params do not have a timestamp - 666
  1. IF ($G(INACTDT)&$P(INACTDT,".",2)="")!($P(ACTDT,".",2)="")!($P(BEGINDT,".",2)="")!($P(ENDDT,".",2)="") DO
  1. . S INACTDT=$P(INACTDT,".",1)
  1. . S ACTDT=$P(ACTDT,".",1)
  1. . S BEGINDT=$P(BEGINDT,".",1)
  1. . S ENDDT=$P(ENDDT,".",1)
  1. ; begin is after inactivation
  1. IF $G(INACTDT),BEGINDT>=INACTDT G DTCHKQ ;666
  1. ; end is before effective date
  1. IF ENDDT<ACTDT G DTCHKQ
  1. ; inactivation exists & isn't after end
  1. IF $G(INACTDT),INACTDT<=ENDDT G DTCHKQ ;666
  1. ; just need 1 day in range
  1. IF $G(INCL)=0 S OK=1 G DTCHKQ
  1. ; begin is not before effective date
  1. IF ACTDT>BEGINDT G DTCHKQ
  1. ; inactivation exists & isn't after end
  1. IF $G(INACTDT),INACTDT<=ENDDT G DTCHKQ ;666
  1. S OK=1
  1. DTCHKQ Q OK
  1. ;
  1. ERR(SEQ,ERNUM,PARMS,OUTPUT,SCER) ;-- process errors
  1. ;if no dialog entry 4040000 will be processed
  1. S ERNUM=$G(ERNUM,4040000)
  1. S:'$$GET1^DIQ(.84,$G(ERNUM)_",",.01) ERNUM=4040000
  1. IF SCER]"" D
  1. . S SEQ=SEQ+1
  1. . S SCER(SEQ)=ERNUM
  1. .D BLD^DIALOG(.ERNUM,.PARMS,.OUTPUT,.SCER)
  1. Q
  1. ;
  1. OKARRAY(ARRAY,CHECK) ; see if input array says 'check' should be used
  1. ; DOES NOT change any varriables - $$okarray(.xx,.yy) is safe...
  1. ; if array is null OR undefined it is ok
  1. ; if @array@(check) is defined it is ok
  1. ; if @array@('exclude') is defined results switch
  1. ; RETURNS: 1: Yes use/0: No don't
  1. Q $S('$L($G(CHECK)):1,'$L($G(ARRAY)):1,(ARRAY'?1A1.7AN):0,1:'(($D(@ARRAY@(CHECK))#2)=($D(@ARRAY@("EXCLUDE"))#2))) ;changed to quit if check is not defined
  1. ;
  1. OKUSRCL(USRARRAY,CHECK) ; see if input user class array says 'check' is ok
  1. N SCOK,SCU
  1. S SCOK=0
  1. IF '$L($G(CHECK))!('$L($G(USRARRAY))) S SCOK=1 G QTOKUSR
  1. IF (USRARRAY'?1A1.7AN)&(USRARRAY'?1"^"1A.E) G QTOKUSR
  1. S SCU=0
  1. IF $D(@USRARRAY@("EXCLUDE"))#2 D
  1. .S SCOK=1
  1. .F S SCU=$O(@USRARRAY@(SCU)) Q:'SCU S:(CHECK=SCU)!($$SUBCLASS^USRLM(CHECK,SCU)) SCOK=0
  1. ELSE D
  1. .S SCOK=0
  1. .F S SCU=$O(@USRARRAY@(SCU)) Q:'SCU S:(CHECK=SCU)!($$SUBCLASS^USRLM(CHECK,SCU)) SCOK=1
  1. .
  1. QTOKUSR Q SCOK