SCMCLN1 ;swo/iofobp cleanup utilities ;2.12.2007
;;5.3;Scheduling;**498**;8.13.1993;Build 23
Q
INST ;check each teams institution and make sure it contains at least the
;stations base numeric identifier
N SCMCSTA,SCMCL1,SCMCZN,SCMCV1,SCMCNT
S SCMCSTA=$$NS^XUAF4(DUZ(2))
I $G(DUZ(2))="" W !,"Institution is undefined...exiting",!! Q
W !,"Your Station Name: "_$P(SCMCSTA,U)
W !," Number: "_$P(SCMCSTA,U,2)
W !,"This option will output a list of TEAMS whose Station Number association"
W !,"does not match the number listed above.",!!
S (SCMCL1,SCMCNT)=0
F S SCMCL1=$O(^SCTM(404.51,SCMCL1)) Q:'SCMCL1 D
. S SCMCZN=$G(^SCTM(404.51,SCMCL1,0)) Q:SCMCZN=""
. S SCMCV1=$E($P($G(^DIC(4,+$P(SCMCZN,U,7),99)),U),1,3) Q:SCMCV1=""
. I $P(SCMCSTA,U,2)'=SCMCV1 D LOG
. Q
D SHOW,CLEAN
Q
SHOW ;see what we got
S DIOEND="D FOOT^SCMCLN1"
S DIC="^SCTM(404.51,",L=0,BY="@.01",(FR,TO)="",FLDS=".01,.07,.07:99;""STATION #"""
S BY(0)="^TMP(""SCMCLN1"",$J,"
S L(0)=1 D EN1^DIP
Q
LOG ;collect the entries with possible incorrect institution
S ^TMP("SCMCLN1",$J,SCMCL1)=""
S SCMCNT=SCMCNT+1
Q
CLEAN ;clean up
K ^TMP("SCMCLN1",$J)
Q
I SCMCNT<1 W !!,"No problems found.",!! Q
W !!,"The listed entries from the TEAM file need to be reviewed for Institution."
W !,"PCMM GUI clients prior to SD*5.3*297 allowed Team association to any entry"
W !,"in the Institution File."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCLN1 1450 printed Sep 23, 2025@20:17:09 Page 2
SCMCLN1 ;swo/iofobp cleanup utilities ;2.12.2007
+1 ;;5.3;Scheduling;**498**;8.13.1993;Build 23
+2 QUIT
INST ;check each teams institution and make sure it contains at least the
+1 ;stations base numeric identifier
+2 NEW SCMCSTA,SCMCL1,SCMCZN,SCMCV1,SCMCNT
+3 SET SCMCSTA=$$NS^XUAF4(DUZ(2))
+4 IF $GET(DUZ(2))=""
WRITE !,"Institution is undefined...exiting",!!
QUIT
+5 WRITE !,"Your Station Name: "_$PIECE(SCMCSTA,U)
+6 WRITE !," Number: "_$PIECE(SCMCSTA,U,2)
+7 WRITE !,"This option will output a list of TEAMS whose Station Number association"
+8 WRITE !,"does not match the number listed above.",!!
+9 SET (SCMCL1,SCMCNT)=0
+10 FOR
SET SCMCL1=$ORDER(^SCTM(404.51,SCMCL1))
if 'SCMCL1
QUIT
Begin DoDot:1
+11 SET SCMCZN=$GET(^SCTM(404.51,SCMCL1,0))
if SCMCZN=""
QUIT
+12 SET SCMCV1=$EXTRACT($PIECE($GET(^DIC(4,+$PIECE(SCMCZN,U,7),99)),U),1,3)
if SCMCV1=""
QUIT
+13 IF $PIECE(SCMCSTA,U,2)'=SCMCV1
DO LOG
+14 QUIT
End DoDot:1
+15 DO SHOW
DO CLEAN
+16 QUIT
SHOW ;see what we got
+1 SET DIOEND="D FOOT^SCMCLN1"
+2 SET DIC="^SCTM(404.51,"
SET L=0
SET BY="@.01"
SET (FR,TO)=""
SET FLDS=".01,.07,.07:99;""STATION #"""
+3 SET BY(0)="^TMP(""SCMCLN1"",$J,"
+4 SET L(0)=1
DO EN1^DIP
+5 QUIT
LOG ;collect the entries with possible incorrect institution
+1 SET ^TMP("SCMCLN1",$JOB,SCMCL1)=""
+2 SET SCMCNT=SCMCNT+1
+3 QUIT
CLEAN ;clean up
+1 KILL ^TMP("SCMCLN1",$JOB)
+2 QUIT
+1 IF SCMCNT<1
WRITE !!,"No problems found.",!!
QUIT
+2 WRITE !!,"The listed entries from the TEAM file need to be reviewed for Institution."
+3 WRITE !,"PCMM GUI clients prior to SD*5.3*297 allowed Team association to any entry"
+4 WRITE !,"in the Institution File."
+5 QUIT
