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 Oct 16, 2024@18:38:59 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 ;
