SCMCMU4 ;ALB/MJK - PCMM Mass Team/Position Unassignment Bulletin ; 10-JUL-1998
;;5.3;Scheduling;**148**;AUG 13, 1993
;
BULL ; -- send bulletin
N SCLCNT,XMY,XMTEXT,XMSUB,XMDUZ,SCINFO
D INIT
D TEXT
D ^XMD
D FINAL
Q
;
INIT ; -- set vars for bulletin
N SCCLN
S XMDUZ=.5
S XMY($S($G(DUZ):DUZ,1:XMDUZ))=""
S XMSUB="Mass Team"_$S(SCMUTYPE="P":"Position",1:"")_" Unassignment Information"
K ^TMP("SCMUTEXT",$J) S XMTEXT="^TMP(""SCMUTEXT"",$J,",SCLCNT=0
;
S SCINFO("NAME","TEAM")=$P($G(^SCTM(404.51,+$G(SCTEAM),0),"Unknown"),U)
;
IF SCMUTYPE="P" D
. S SCPOS0=$G(^SCTM(404.57,+$G(SCPOS),0),"Unknown")
. S SCINFO("NAME","POSITION")=$P(SCPOS0,U)
. S SCCLN=+$P(SCPOS0,U,9)
. IF SCCLN S SCINFO("NAME","CLINIC")=$P($G(^SC(SCCLN,0),""),U)
. Q
;
S SCINFO("NAME","USER")=$P($G(^VA(200,XMDUZ,0),"Unknown"),U)
S SCINFO("DATE","EFFECTIVE")=$$FMTE^XLFDT($E(SCDATE,1,7),"5Z")
;
Q
;
FINAL ; -- clean up
K ^TMP("SCMUTEXT",$J)
Q
;
TEXT ; -- set of mm array
D SET("Mass Team"_$S(SCMUTYPE="P":"-Position",1:"")_" Unassignment has been completed.")
D SET("")
D SET(" Team: "_SCINFO("NAME","TEAM"))
;
IF SCMUTYPE="P" D
. D SET(" Position: "_SCINFO("NAME","POSITION"))
. IF $G(SCINFO("NAME","CLINIC"))]"" D SET(" Clinic: "_SCINFO("NAME","CLINIC"))
. Q
;
D SET(" User: "_SCINFO("NAME","USER"))
D SET(" Effective Date: "_SCINFO("DATE","EFFECTIVE"))
;
D SET("")
D SET(" Patients Processed")
D SET(" Unassigned : "_SCUNCNT)
D SET(" Errors/Warnings: "_SCASCNT_" (still assigned)")
D SET(" Total : "_SCSELCNT)
;
D CLINIC
D SET("")
;
; -- list pats that remain assigned
D ERRARY
;
D SET("")
D SET("")
;
; -- list pats unassigned
D OKARY
Q
;
SET(X) ;
S SCLCNT=SCLCNT+1,^TMP("SCMUTEXT",$J,SCLCNT,0)=X
Q
;
ERRARY ; -- process error array
N SCNT,SCX,SCER,SCERI
;
D SET(" Error List:")
D SET(" ===========")
;
IF '$O(@SCBADAR@(0)) D Q
. D SET(" No errors to report.")
. Q
;
D HDR
;
S SCNT=0
F S SCNT=$O(@SCBADAR@(SCNT)) Q:'SCNT D
. S SCX=@SCBADAR@(SCNT)
. D PT(SCNT)
. ;
. IF '$D(@SCERRAR@(SCNT)) Q
. S SCERI=0
. F S SCERI=$O(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI)) Q:'SCERI D
. . S SCER=$G(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI))
. . D SET(" >>> "_SCER)
. . Q
. ;
. IF '$O(@SCERRAR@(SCNT,"POS",0)) Q
. S SCPOS=0
. F S SCPOS=$O(@SCERRAR@(SCNT,"POS",SCPOS)) Q:'SCPOS D
. . IF SCMUTYPE="T" D SET(" >>> Position: "_$P($G(^SCTM(404.57,SCPOS,0),"Unknown"),U))
. . S SCERI=0
. . F S SCERI=$O(@SCERRAR@(SCNT,"POS",SCPOS,SCERI)) Q:'SCERI D
. . . S SCER=$G(@SCERRAR@(SCNT,"POS",SCPOS,SCERI))
. . . D SET(" >>>> "_SCER)
. . . Q
. . Q
. D SET("")
. Q
Q
;
OKARY ; -- process ok array
N SCNT,SCPT,SCX
D SET(" Unassigned List:")
D SET(" ================")
;
IF '$O(@SCOKAR@(0)) D Q
. D SET(" No patients unassigned.")
. Q
;
D HDR
;
S SCNT=0
F S SCNT=$O(@SCOKAR@(SCNT)) Q:'SCNT D
. D PT(SCNT)
. D TM(SCNT)
. D POS(SCNT)
. Q
Q
;
HDR ; -- send patient info header
S X=""
S X=$$SETSTR^VALM1("Patient",X,2,7)
S X=$$SETSTR^VALM1("ID",X,40,2)
D SET(X)
;
S X=""
S X=$$SETSTR^VALM1("-------",X,2,7)
S X=$$SETSTR^VALM1("--",X,40,2)
D SET(X)
Q
;
PT(SCNT) ; -- send patient info
N NAME,ID,X,SCPT,SCX
S SCPT=$G(@SCPTINFO@(SCNT))
S NAME=$P(SCPT,U,2)
S ID=$P(SCPT,U,6)
S X=""
S X=$$SETSTR^VALM1(NAME,X,2,30)
S X=$$SETSTR^VALM1(ID,X,40,15)
D SET(X)
Q
;
TM(SCNT) ; -- show any team info for patient
N SCTMMSG
S SCTMMSG=$G(@SCOKAR@(SCNT,"TEAM",SCTEAM,1))
D INFO("TEAM",SCTEAM)
Q
;
POS(SCNT) ; -- send position (for team unassignment) & clinic discharge info
N SCPOS,SCTPMSG,SCCLNM,SCPOS0,SCLNX,SCI
S SCPOS=0
F S SCPOS=$O(@SCOKAR@(SCNT,"POS",SCPOS)) Q:'SCPOS D
. S SCTPMSG=$G(@SCOKAR@(SCNT,"POS",SCPOS,1))
. S SCLNX=$G(@SCOKAR@(SCNT,"CLINIC",SCPOS,1))
. S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
. ;
. IF SCMUTYPE="T" D
. . D SET(" >>> Position assignment to "_$P(SCPOS0,U)_$S(SCTPMSG="":" was unassigned.",1:":"))
. D INFO("POS",SCPOS)
. ;
. IF SCLNX]"",$D(SCTPDIS(SCPOS)) D
. . S SCCLNM=$P($G(^SC(+$P(SCPOS0,U,9),0),"Unkown"),U)
. . IF +SCLNX=1 D SET(" >>> Discharged from '"_SCCLNM_"' clinic")
. . IF +SCLNX=2 D
. . . D SET(" Still enrolled in '"_SCCLNM_"' clinic")
. . . D SET(" Reason: "_$P(SCLNX,U,2))
. . Q
. Q
Q
;
CLINIC ; -- display clinic to be discharged from
N SCPOS,SCX,Y
D SET(" ")
IF '$O(SCTPDIS(0)) D G CLINICQ
. D SET(" Clinic Discharges: None")
. Q
;
S Y=""
S Y=$$SETSTR^VALM1("Clinic Discharges:",Y,2,20)
S Y=$$SETSTR^VALM1("Position",Y,25,25)
S Y=$$SETSTR^VALM1("Associated Clinic",Y,55,25)
D SET(Y)
S Y=""
S Y=$$SETSTR^VALM1("--------",Y,25,25)
S Y=$$SETSTR^VALM1("-----------------",Y,55,25)
D SET(Y)
;
S SCPOS=0
F S SCPOS=$O(SCTPDIS(SCPOS)) Q:'SCPOS D
. S SCX=$G(^SCTM(404.57,SCPOS,0),"Unknown")
. S Y=""
. S Y=$$SETSTR^VALM1($E($P(SCX,U),1,25),Y,25,25)
. S Y=$$SETSTR^VALM1($E($P($G(^SC(+$P(SCX,U,9),0),"Unknown"),U),1,25),Y,55,25)
. D SET(Y)
. Q
;
CLINICQ Q
;
INFO(TYPE,SCIEN) ; -- load ok info text
N SCI
S SCI=0
F S SCI=$O(@SCOKAR@(SCNT,TYPE,SCIEN,SCI)) Q:'SCI D
. S X=$G(@SCOKAR@(SCNT,TYPE,SCIEN,SCI))
. IF X]"" D SET(" "_X)
. Q
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMU4 5444 printed Sep 23, 2025@20:17:24 Page 2
SCMCMU4 ;ALB/MJK - PCMM Mass Team/Position Unassignment Bulletin ; 10-JUL-1998
+1 ;;5.3;Scheduling;**148**;AUG 13, 1993
+2 ;
BULL ; -- send bulletin
+1 NEW SCLCNT,XMY,XMTEXT,XMSUB,XMDUZ,SCINFO
+2 DO INIT
+3 DO TEXT
+4 DO ^XMD
+5 DO FINAL
+6 QUIT
+7 ;
INIT ; -- set vars for bulletin
+1 NEW SCCLN
+2 SET XMDUZ=.5
+3 SET XMY($SELECT($GET(DUZ):DUZ,1:XMDUZ))=""
+4 SET XMSUB="Mass Team"_$SELECT(SCMUTYPE="P":"Position",1:"")_" Unassignment Information"
+5 KILL ^TMP("SCMUTEXT",$JOB)
SET XMTEXT="^TMP(""SCMUTEXT"",$J,"
SET SCLCNT=0
+6 ;
+7 SET SCINFO("NAME","TEAM")=$PIECE($GET(^SCTM(404.51,+$GET(SCTEAM),0),"Unknown"),U)
+8 ;
+9 IF SCMUTYPE="P"
Begin DoDot:1
+10 SET SCPOS0=$GET(^SCTM(404.57,+$GET(SCPOS),0),"Unknown")
+11 SET SCINFO("NAME","POSITION")=$PIECE(SCPOS0,U)
+12 SET SCCLN=+$PIECE(SCPOS0,U,9)
+13 IF SCCLN
SET SCINFO("NAME","CLINIC")=$PIECE($GET(^SC(SCCLN,0),""),U)
+14 QUIT
End DoDot:1
+15 ;
+16 SET SCINFO("NAME","USER")=$PIECE($GET(^VA(200,XMDUZ,0),"Unknown"),U)
+17 SET SCINFO("DATE","EFFECTIVE")=$$FMTE^XLFDT($EXTRACT(SCDATE,1,7),"5Z")
+18 ;
+19 QUIT
+20 ;
FINAL ; -- clean up
+1 KILL ^TMP("SCMUTEXT",$JOB)
+2 QUIT
+3 ;
TEXT ; -- set of mm array
+1 DO SET("Mass Team"_$SELECT(SCMUTYPE="P":"-Position",1:"")_" Unassignment has been completed.")
+2 DO SET("")
+3 DO SET(" Team: "_SCINFO("NAME","TEAM"))
+4 ;
+5 IF SCMUTYPE="P"
Begin DoDot:1
+6 DO SET(" Position: "_SCINFO("NAME","POSITION"))
+7 IF $GET(SCINFO("NAME","CLINIC"))]""
DO SET(" Clinic: "_SCINFO("NAME","CLINIC"))
+8 QUIT
End DoDot:1
+9 ;
+10 DO SET(" User: "_SCINFO("NAME","USER"))
+11 DO SET(" Effective Date: "_SCINFO("DATE","EFFECTIVE"))
+12 ;
+13 DO SET("")
+14 DO SET(" Patients Processed")
+15 DO SET(" Unassigned : "_SCUNCNT)
+16 DO SET(" Errors/Warnings: "_SCASCNT_" (still assigned)")
+17 DO SET(" Total : "_SCSELCNT)
+18 ;
+19 DO CLINIC
+20 DO SET("")
+21 ;
+22 ; -- list pats that remain assigned
+23 DO ERRARY
+24 ;
+25 DO SET("")
+26 DO SET("")
+27 ;
+28 ; -- list pats unassigned
+29 DO OKARY
+30 QUIT
+31 ;
SET(X) ;
+1 SET SCLCNT=SCLCNT+1
SET ^TMP("SCMUTEXT",$JOB,SCLCNT,0)=X
+2 QUIT
+3 ;
ERRARY ; -- process error array
+1 NEW SCNT,SCX,SCER,SCERI
+2 ;
+3 DO SET(" Error List:")
+4 DO SET(" ===========")
+5 ;
+6 IF '$ORDER(@SCBADAR@(0))
Begin DoDot:1
+7 DO SET(" No errors to report.")
+8 QUIT
End DoDot:1
QUIT
+9 ;
+10 DO HDR
+11 ;
+12 SET SCNT=0
+13 FOR
SET SCNT=$ORDER(@SCBADAR@(SCNT))
if 'SCNT
QUIT
Begin DoDot:1
+14 SET SCX=@SCBADAR@(SCNT)
+15 DO PT(SCNT)
+16 ;
+17 IF '$DATA(@SCERRAR@(SCNT))
QUIT
+18 SET SCERI=0
+19 FOR
SET SCERI=$ORDER(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI))
if 'SCERI
QUIT
Begin DoDot:2
+20 SET SCER=$GET(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI))
+21 DO SET(" >>> "_SCER)
+22 QUIT
End DoDot:2
+23 ;
+24 IF '$ORDER(@SCERRAR@(SCNT,"POS",0))
QUIT
+25 SET SCPOS=0
+26 FOR
SET SCPOS=$ORDER(@SCERRAR@(SCNT,"POS",SCPOS))
if 'SCPOS
QUIT
Begin DoDot:2
+27 IF SCMUTYPE="T"
DO SET(" >>> Position: "_$PIECE($GET(^SCTM(404.57,SCPOS,0),"Unknown"),U))
+28 SET SCERI=0
+29 FOR
SET SCERI=$ORDER(@SCERRAR@(SCNT,"POS",SCPOS,SCERI))
if 'SCERI
QUIT
Begin DoDot:3
+30 SET SCER=$GET(@SCERRAR@(SCNT,"POS",SCPOS,SCERI))
+31 DO SET(" >>>> "_SCER)
+32 QUIT
End DoDot:3
+33 QUIT
End DoDot:2
+34 DO SET("")
+35 QUIT
End DoDot:1
+36 QUIT
+37 ;
OKARY ; -- process ok array
+1 NEW SCNT,SCPT,SCX
+2 DO SET(" Unassigned List:")
+3 DO SET(" ================")
+4 ;
+5 IF '$ORDER(@SCOKAR@(0))
Begin DoDot:1
+6 DO SET(" No patients unassigned.")
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 DO HDR
+10 ;
+11 SET SCNT=0
+12 FOR
SET SCNT=$ORDER(@SCOKAR@(SCNT))
if 'SCNT
QUIT
Begin DoDot:1
+13 DO PT(SCNT)
+14 DO TM(SCNT)
+15 DO POS(SCNT)
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
HDR ; -- send patient info header
+1 SET X=""
+2 SET X=$$SETSTR^VALM1("Patient",X,2,7)
+3 SET X=$$SETSTR^VALM1("ID",X,40,2)
+4 DO SET(X)
+5 ;
+6 SET X=""
+7 SET X=$$SETSTR^VALM1("-------",X,2,7)
+8 SET X=$$SETSTR^VALM1("--",X,40,2)
+9 DO SET(X)
+10 QUIT
+11 ;
PT(SCNT) ; -- send patient info
+1 NEW NAME,ID,X,SCPT,SCX
+2 SET SCPT=$GET(@SCPTINFO@(SCNT))
+3 SET NAME=$PIECE(SCPT,U,2)
+4 SET ID=$PIECE(SCPT,U,6)
+5 SET X=""
+6 SET X=$$SETSTR^VALM1(NAME,X,2,30)
+7 SET X=$$SETSTR^VALM1(ID,X,40,15)
+8 DO SET(X)
+9 QUIT
+10 ;
TM(SCNT) ; -- show any team info for patient
+1 NEW SCTMMSG
+2 SET SCTMMSG=$GET(@SCOKAR@(SCNT,"TEAM",SCTEAM,1))
+3 DO INFO("TEAM",SCTEAM)
+4 QUIT
+5 ;
POS(SCNT) ; -- send position (for team unassignment) & clinic discharge info
+1 NEW SCPOS,SCTPMSG,SCCLNM,SCPOS0,SCLNX,SCI
+2 SET SCPOS=0
+3 FOR
SET SCPOS=$ORDER(@SCOKAR@(SCNT,"POS",SCPOS))
if 'SCPOS
QUIT
Begin DoDot:1
+4 SET SCTPMSG=$GET(@SCOKAR@(SCNT,"POS",SCPOS,1))
+5 SET SCLNX=$GET(@SCOKAR@(SCNT,"CLINIC",SCPOS,1))
+6 SET SCPOS0=$GET(^SCTM(404.57,SCPOS,0))
+7 ;
+8 IF SCMUTYPE="T"
Begin DoDot:2
+9 DO SET(" >>> Position assignment to "_$PIECE(SCPOS0,U)_$SELECT(SCTPMSG="":" was unassigned.",1:":"))
End DoDot:2
+10 DO INFO("POS",SCPOS)
+11 ;
+12 IF SCLNX]""
IF $DATA(SCTPDIS(SCPOS))
Begin DoDot:2
+13 SET SCCLNM=$PIECE($GET(^SC(+$PIECE(SCPOS0,U,9),0),"Unkown"),U)
+14 IF +SCLNX=1
DO SET(" >>> Discharged from '"_SCCLNM_"' clinic")
+15 IF +SCLNX=2
Begin DoDot:3
+16 DO SET(" Still enrolled in '"_SCCLNM_"' clinic")
+17 DO SET(" Reason: "_$PIECE(SCLNX,U,2))
End DoDot:3
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
CLINIC ; -- display clinic to be discharged from
+1 NEW SCPOS,SCX,Y
+2 DO SET(" ")
+3 IF '$ORDER(SCTPDIS(0))
Begin DoDot:1
+4 DO SET(" Clinic Discharges: None")
+5 QUIT
End DoDot:1
GOTO CLINICQ
+6 ;
+7 SET Y=""
+8 SET Y=$$SETSTR^VALM1("Clinic Discharges:",Y,2,20)
+9 SET Y=$$SETSTR^VALM1("Position",Y,25,25)
+10 SET Y=$$SETSTR^VALM1("Associated Clinic",Y,55,25)
+11 DO SET(Y)
+12 SET Y=""
+13 SET Y=$$SETSTR^VALM1("--------",Y,25,25)
+14 SET Y=$$SETSTR^VALM1("-----------------",Y,55,25)
+15 DO SET(Y)
+16 ;
+17 SET SCPOS=0
+18 FOR
SET SCPOS=$ORDER(SCTPDIS(SCPOS))
if 'SCPOS
QUIT
Begin DoDot:1
+19 SET SCX=$GET(^SCTM(404.57,SCPOS,0),"Unknown")
+20 SET Y=""
+21 SET Y=$$SETSTR^VALM1($EXTRACT($PIECE(SCX,U),1,25),Y,25,25)
+22 SET Y=$$SETSTR^VALM1($EXTRACT($PIECE($GET(^SC(+$PIECE(SCX,U,9),0),"Unknown"),U),1,25),Y,55,25)
+23 DO SET(Y)
+24 QUIT
End DoDot:1
+25 ;
CLINICQ QUIT
+1 ;
INFO(TYPE,SCIEN) ; -- load ok info text
+1 NEW SCI
+2 SET SCI=0
+3 FOR
SET SCI=$ORDER(@SCOKAR@(SCNT,TYPE,SCIEN,SCI))
if 'SCI
QUIT
Begin DoDot:1
+4 SET X=$GET(@SCOKAR@(SCNT,TYPE,SCIEN,SCI))
+5 IF X]""
DO SET(" "_X)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
