- SCAPMCU5 ;bp/cmf - TEAM API UTILITIES ; 2 june 1999
- ;;5.3;Scheduling;**177**;AUG 13, 1993
- ;;1.0
- ;
- VALHIST(SCFILE,SCTPIEN,SCVAL) ; returns valid act/inact ien pairs in SCVAL
- ;
- S SCFILE=$G(SCFILE,0)
- I "^404.58^404.59^404.52^404.53^"'[SCFILE Q $$S(1)
- S SCTPIEN=+$G(SCTPIEN,0)
- I SCTPIEN<1!('$D(^SCTM(404.57,SCTPIEN))) Q $$S(2)
- S SCVAL=$G(SCVAL,"")
- I SCVAL']"" Q $$S(3)
- ;
- N SCCNT,SCTOP,SCX,SCACT,SCACT1,SCINACT,SCINACT1,SCFIRST,SCSTOP
- M SCX(1)=^SCTM(SCFILE,"AIDT",SCTPIEN,1)
- M SCX(0)=^SCTM(SCFILE,"AIDT",SCTPIEN,0)
- S SCCNT=0
- S SCTOP=0
- S SCACT=-9999999 ;act dt
- F S SCACT=$O(SCX(1,SCACT)) Q:'SCACT D
- . S SCACT1="" ;act ien
- . F S SCACT1=$O(SCX(1,SCACT,SCACT1),-1) Q:'SCACT1 D
- . . S SCINACT=SCACT ;inact dt
- . . I $D(SCX(0,SCINACT)) Q:$$INACT()
- . . S SCINACT=$O(SCX(0,SCINACT),-1) ;next? inact dt
- . . I SCINACT="" D Q ;current asgn
- . . . Q:SCTOP
- . . . D VALID
- . . . S SCTOP=1
- . . . Q
- . . S SCX=$$INACT()
- . . Q
- . Q
- ;
- S SCFIRST=0_U_0
- I $G(@SCVAL@(0))>0 D
- . S SCCNT=@SCVAL@(0)
- . S SCACT=$O(@SCVAL@(SCCNT,0))
- . S SCACT1=$O(@SCVAL@(SCCNT,SCACT,0))
- . S SCFIRST=SCACT_U_SCACT1
- . Q
- Q ($D(SCX(1)))!($D(SCX(0)))_U_SCFIRST
- ;
- INACT() S SCSTOP=0
- S SCINACT1=SCACT1 ;inact ien
- F S SCINACT1=$O(SCX(0,SCINACT,SCINACT1)) Q:'SCINACT1!(SCSTOP) D
- . I "^404.58^404.59^"[SCFILE D VALID Q
- . I SCFILE=404.52,$$CP(3) D VALID Q
- . I SCFILE=404.53,$$CP(6) D VALID Q
- . Q
- Q SCSTOP
- ;
- VALID S SCCNT=SCCNT+1
- S SCX=$S(+$G(SCINACT):-SCINACT,1:"")_U_$S(+$G(SCINACT1):SCINACT1,1:"")
- I SCX=U,SCCNT>1 S SCCNT=SCCNT-1 Q ;latest entry ONLY should have empty inact data
- S @SCVAL@(SCCNT,-SCACT,SCACT1)=SCX
- S @SCVAL@(0)=SCCNT
- S @SCVAL@("I",SCACT1,SCCNT)=""
- K SCX(1,SCACT,SCACT1)
- I SCINACT'="",SCINACT1'="" K SCX(0,SCINACT,SCINACT1)
- S SCSTOP=1
- Q
- ;
- CP(SCX) ; if 404.52, practitioner (.03)s must match
- ; if 404.53, preceptor (.06)s must match
- Q $P(^SCTM(SCFILE,SCACT1,0),U,SCX)=$P(^SCTM(SCFILE,SCINACT1,0),U,SCX)
- ;
- ;
- ACTHIST(SCVAL,SCDATES) ;given val hist array, prior active?
- ; input: scval = scval array produced by $$valhist call, above
- ; scdates = standard PCMM date array
- ;
- ; output: p1 = prior activation: 1=yes, 0=no
- ; p2 = active as of end date: 1=yes, 0=no
- ; p3 = if p2=1, activation ien, else inactivation ien
- ;
- N SCX,SCX1,SCX2,SCA,SCDATE,SCP1,SCP2
- I '$D(@SCVAL)!($G(@SCVAL@(0))<1) Q $$S(4)
- I '$D(@SCDATES) Q $$S(5)
- S SCDATE=$G(@SCDATES@("END"),DT)+.000001
- ; arrange scval by assign date
- F SCX=1:1:@SCVAL@(0) D
- . S SCX1=$O(@SCVAL@(SCX,0))
- . S SCX2=$O(@SCVAL@(SCX,SCX1,0))
- . S SCA(SCX1,SCX2)=@SCVAL@(SCX,SCX1,SCX2)
- . Q
- S SCX1=+$O(SCA(SCDATE),-1)
- S SCP1=(SCX1>0)
- S (SCP2,SCP3)=0
- I +SCP1 D
- . S SCX2=$O(SCA(SCX1,""),-1)
- . S SCX=$P(SCA(SCX1,SCX2),U)
- . S SCDATE=SCDATE-.000001
- . I (SCX="")!(SCX'<SCDATE) S SCP2=1
- . S SCP3=$S(SCP2=1:SCX2,1:$P(SCA(SCX1,SCX2),U,2))
- Q SCP1_U_SCP2_U_SCP3
- ;
- S(SCX) Q "Invalid "_$P($T(T+SCX),";;",2)
- ;
- T ;
- ;;File Number;;
- ;;Team Position Ien;;
- ;;(null) Result Array;;
- ;;(null) History Array;;
- ;;(null) Date Array;;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMCU5 3313 printed Feb 19, 2025@00:04:49 Page 2
- SCAPMCU5 ;bp/cmf - TEAM API UTILITIES ; 2 june 1999
- +1 ;;5.3;Scheduling;**177**;AUG 13, 1993
- +2 ;;1.0
- +3 ;
- VALHIST(SCFILE,SCTPIEN,SCVAL) ; returns valid act/inact ien pairs in SCVAL
- +1 ;
- +2 SET SCFILE=$GET(SCFILE,0)
- +3 IF "^404.58^404.59^404.52^404.53^"'[SCFILE
- QUIT $$S(1)
- +4 SET SCTPIEN=+$GET(SCTPIEN,0)
- +5 IF SCTPIEN<1!('$DATA(^SCTM(404.57,SCTPIEN)))
- QUIT $$S(2)
- +6 SET SCVAL=$GET(SCVAL,"")
- +7 IF SCVAL']""
- QUIT $$S(3)
- +8 ;
- +9 NEW SCCNT,SCTOP,SCX,SCACT,SCACT1,SCINACT,SCINACT1,SCFIRST,SCSTOP
- +10 MERGE SCX(1)=^SCTM(SCFILE,"AIDT",SCTPIEN,1)
- +11 MERGE SCX(0)=^SCTM(SCFILE,"AIDT",SCTPIEN,0)
- +12 SET SCCNT=0
- +13 SET SCTOP=0
- +14 ;act dt
- SET SCACT=-9999999
- +15 FOR
- SET SCACT=$ORDER(SCX(1,SCACT))
- if 'SCACT
- QUIT
- Begin DoDot:1
- +16 ;act ien
- SET SCACT1=""
- +17 FOR
- SET SCACT1=$ORDER(SCX(1,SCACT,SCACT1),-1)
- if 'SCACT1
- QUIT
- Begin DoDot:2
- +18 ;inact dt
- SET SCINACT=SCACT
- +19 IF $DATA(SCX(0,SCINACT))
- if $$INACT()
- QUIT
- +20 ;next? inact dt
- SET SCINACT=$ORDER(SCX(0,SCINACT),-1)
- +21 ;current asgn
- IF SCINACT=""
- Begin DoDot:3
- +22 if SCTOP
- QUIT
- +23 DO VALID
- +24 SET SCTOP=1
- +25 QUIT
- End DoDot:3
- QUIT
- +26 SET SCX=$$INACT()
- +27 QUIT
- End DoDot:2
- +28 QUIT
- End DoDot:1
- +29 ;
- +30 SET SCFIRST=0_U_0
- +31 IF $GET(@SCVAL@(0))>0
- Begin DoDot:1
- +32 SET SCCNT=@SCVAL@(0)
- +33 SET SCACT=$ORDER(@SCVAL@(SCCNT,0))
- +34 SET SCACT1=$ORDER(@SCVAL@(SCCNT,SCACT,0))
- +35 SET SCFIRST=SCACT_U_SCACT1
- +36 QUIT
- End DoDot:1
- +37 QUIT ($DATA(SCX(1)))!($DATA(SCX(0)))_U_SCFIRST
- +38 ;
- INACT() SET SCSTOP=0
- +1 ;inact ien
- SET SCINACT1=SCACT1
- +2 FOR
- SET SCINACT1=$ORDER(SCX(0,SCINACT,SCINACT1))
- if 'SCINACT1!(SCSTOP)
- QUIT
- Begin DoDot:1
- +3 IF "^404.58^404.59^"[SCFILE
- DO VALID
- QUIT
- +4 IF SCFILE=404.52
- IF $$CP(3)
- DO VALID
- QUIT
- +5 IF SCFILE=404.53
- IF $$CP(6)
- DO VALID
- QUIT
- +6 QUIT
- End DoDot:1
- +7 QUIT SCSTOP
- +8 ;
- VALID SET SCCNT=SCCNT+1
- +1 SET SCX=$SELECT(+$GET(SCINACT):-SCINACT,1:"")_U_$SELECT(+$GET(SCINACT1):SCINACT1,1:"")
- +2 ;latest entry ONLY should have empty inact data
- IF SCX=U
- IF SCCNT>1
- SET SCCNT=SCCNT-1
- QUIT
- +3 SET @SCVAL@(SCCNT,-SCACT,SCACT1)=SCX
- +4 SET @SCVAL@(0)=SCCNT
- +5 SET @SCVAL@("I",SCACT1,SCCNT)=""
- +6 KILL SCX(1,SCACT,SCACT1)
- +7 IF SCINACT'=""
- IF SCINACT1'=""
- KILL SCX(0,SCINACT,SCINACT1)
- +8 SET SCSTOP=1
- +9 QUIT
- +10 ;
- CP(SCX) ; if 404.52, practitioner (.03)s must match
- +1 ; if 404.53, preceptor (.06)s must match
- +2 QUIT $PIECE(^SCTM(SCFILE,SCACT1,0),U,SCX)=$PIECE(^SCTM(SCFILE,SCINACT1,0),U,SCX)
- +3 ;
- +4 ;
- ACTHIST(SCVAL,SCDATES) ;given val hist array, prior active?
- +1 ; input: scval = scval array produced by $$valhist call, above
- +2 ; scdates = standard PCMM date array
- +3 ;
- +4 ; output: p1 = prior activation: 1=yes, 0=no
- +5 ; p2 = active as of end date: 1=yes, 0=no
- +6 ; p3 = if p2=1, activation ien, else inactivation ien
- +7 ;
- +8 NEW SCX,SCX1,SCX2,SCA,SCDATE,SCP1,SCP2
- +9 IF '$DATA(@SCVAL)!($GET(@SCVAL@(0))<1)
- QUIT $$S(4)
- +10 IF '$DATA(@SCDATES)
- QUIT $$S(5)
- +11 SET SCDATE=$GET(@SCDATES@("END"),DT)+.000001
- +12 ; arrange scval by assign date
- +13 FOR SCX=1:1:@SCVAL@(0)
- Begin DoDot:1
- +14 SET SCX1=$ORDER(@SCVAL@(SCX,0))
- +15 SET SCX2=$ORDER(@SCVAL@(SCX,SCX1,0))
- +16 SET SCA(SCX1,SCX2)=@SCVAL@(SCX,SCX1,SCX2)
- +17 QUIT
- End DoDot:1
- +18 SET SCX1=+$ORDER(SCA(SCDATE),-1)
- +19 SET SCP1=(SCX1>0)
- +20 SET (SCP2,SCP3)=0
- +21 IF +SCP1
- Begin DoDot:1
- +22 SET SCX2=$ORDER(SCA(SCX1,""),-1)
- +23 SET SCX=$PIECE(SCA(SCX1,SCX2),U)
- +24 SET SCDATE=SCDATE-.000001
- +25 IF (SCX="")!(SCX'<SCDATE)
- SET SCP2=1
- +26 SET SCP3=$SELECT(SCP2=1:SCX2,1:$PIECE(SCA(SCX1,SCX2),U,2))
- End DoDot:1
- +27 QUIT SCP1_U_SCP2_U_SCP3
- +28 ;
- S(SCX) QUIT "Invalid "_$PIECE($TEXT(T+SCX),";;",2)
- +1 ;
- T ;
- +1 ;;File Number;;
- +2 ;;Team Position Ien;;
- +3 ;;(null) Result Array;;
- +4 ;;(null) History Array;;
- +5 ;;(null) Date Array;;
- +6 ;