SCMCTPU4 ;ALB/MJK - Team Position Dangler Bulletin ; 10-JUL-1998
;;5.3;Scheduling;**148,177**;AUG 13, 1993
;
BULL ; -- send bulletin (called from SCMCTPU3)
N XMY,XMTEXT,XMSUB,XMDUZ,SCLCNT
D INIT
D TEXT
IF 'SCSTOP D ^XMD
D FINAL
Q
;
INIT ; -- set vars for bulletin
N SCPCT
S XMDUZ=.5
S XMY($S($G(DUZ):DUZ,1:XMDUZ))=""
S XMSUB="Patient Team Position Assignment Review"
K ^TMP("SCTPTEXT",$J)
S XMTEXT="^TMP(""SCTPTEXT"",$J,"
S SCLCNT=0
S SCPCT="0.00"
IF $G(SCNT("TOTAL")) S SCPCT=(+$G(SCNT("BAD"))/+$G(SCNT("TOTAL")))*100
;
; -- summary info
;
D SET(" In order to correct the following active positions with discharged team")
D SET("assignments, please refer to the documentation for the Patient Team")
D SET("Position Assignment Review option found in the Stand-alone Options")
D SET("Section of the PCMM User Guide.")
D SET(" ")
;
;D SET(" ")
;D SET(" Mode: "_$S(SCMODE=1:"Diagnostic Only",1:"Fix"))
;
; -- show teams
D SET(" Teams Reviewed: "_$S(SCTMLST=1:"All",1:""))
IF SCTMLST=0 D
. ; -- sort and set
. N SCTMI,X
. S SCTMI=0
. F S SCTMI=$O(SCTMLST(SCTMI)) Q:'SCTMI S X(SCTMLST(SCTMI)_SCTMI)=SCTMLST(SCTMI)
. S SCTMI=""
. F S SCTMI=$O(X(SCTMI)) Q:SCTMI="" D SET(" "_X(SCTMI))
. D SET(" ")
. Q
;
D SET(" ")
D SET(" Patient Team Position Assignments Reviewed: "_$J(+$G(SCNT("TOTAL")),6))
D SET(" Number of Assignments with Problems : "_$J(+$G(SCNT("BAD")),6)_" ("_$J(SCPCT,6,2)_"%)")
D SET(" ")
D DASH("=")
Q
;
FINAL ; -- clean up
K ^TMP("SCTPTEXT",$J)
Q
;
TEXT ; -- set of mm array
N SCTMI,SCTPI,SCPTI,SCASDTI,SCPTAI
;
; -- sort is by team, position, patient, assign date, position assignment ien
;
S SCSTOP=0
S SCTMI=""
F S SCTMI=$O(@SCERTMP@(SCTMI)) Q:SCTMI="" D Q:SCSTOP
. S SCTPI="" F S SCTPI=$O(@SCERTMP@(SCTMI,SCTPI)) Q:SCTPI="" D
. . S SCPTI="" F S SCPTI=$O(@SCERTMP@(SCTMI,SCTPI,SCPTI)) Q:SCPTI="" D
. . . S SCASDTI=0 F S SCASDTI=$O(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI)) Q:'SCASDTI D
. . . . S SCTPAI=0 F S SCTPAI=$O(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI,SCTPAI)) Q:'SCTPAI D PTA
. ;
. ; -- check if user asked job to stop
. IF $$S^%ZTLOAD() S (SCSTOP,ZTSTOP)=1
Q
;
PTA ; -- process errors for team position assignment
N SCTP,SCTP0,SCTPNM
N SCTM,SCTM0,SCTMNM
N SCPT,SCPT0,SCPTNM,SCPTID
N SCTPA,SCTPA0,SCTPASDT,SCTPUNDT
N SCTMA,SCTMA0,SCTMASDT,SCTMUNDT
N SCER
; -- get data
D DATA^SCMCTPU3(SCTPAI)
;
; -- set mm text
D SET(" Team: "_SCTMNM_" Position: "_SCTPNM)
D SET(" Patient: "_SCPTNM_" ("_SCPTID_")")
S SCER=0
F S SCER=$O(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI,SCTPAI,SCER)) Q:'SCER D
. IF SCER=1 D
. . D SET(" Error: Position Assigned Date is BEFORE Team Assigned Date")
. . D SET(" Position Assigned Date: "_$$FMTE^XLFDT($E(SCTPASDT,1,7),"5Z"))
. . D SET(" Team Assigned Date: "_$$FMTE^XLFDT($E(SCTMASDT,1,7),"5Z"))
. ;
. IF SCER=2 D
. . D SET(" Error: Position Unassigned Date is AFTER Team Unassigned Date")
. . D SET(" Team Unassigned Date: "_$S(SCTMUNDT=9999999:"<none>",1:$$FMTE^XLFDT($E(SCTMUNDT,1,7),"5Z")))
. . D SET(" Position Unassigned Date: "_$S(SCTPUNDT=9999999:"<none>",1:$$FMTE^XLFDT($E(SCTPUNDT,1,7),"5Z")))
. ; -- do fix if selected
. IF SCMODE=2 D FIX
D DASH()
Q
;
FIX ; -- fix team position assignment entry (future)
Q
;
SET(X) ;
S SCLCNT=SCLCNT+1,^TMP("SCTPTEXT",$J,SCLCNT,0)=X
Q
;
DASH(CHAR) ; -- send line of CHAR
N X
S $P(X,$E($G(CHAR,"-")),78)=""
D SET(" "_X)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTPU4 3684 printed Oct 16, 2024@18:42:05 Page 2
SCMCTPU4 ;ALB/MJK - Team Position Dangler Bulletin ; 10-JUL-1998
+1 ;;5.3;Scheduling;**148,177**;AUG 13, 1993
+2 ;
BULL ; -- send bulletin (called from SCMCTPU3)
+1 NEW XMY,XMTEXT,XMSUB,XMDUZ,SCLCNT
+2 DO INIT
+3 DO TEXT
+4 IF 'SCSTOP
DO ^XMD
+5 DO FINAL
+6 QUIT
+7 ;
INIT ; -- set vars for bulletin
+1 NEW SCPCT
+2 SET XMDUZ=.5
+3 SET XMY($SELECT($GET(DUZ):DUZ,1:XMDUZ))=""
+4 SET XMSUB="Patient Team Position Assignment Review"
+5 KILL ^TMP("SCTPTEXT",$JOB)
+6 SET XMTEXT="^TMP(""SCTPTEXT"",$J,"
+7 SET SCLCNT=0
+8 SET SCPCT="0.00"
+9 IF $GET(SCNT("TOTAL"))
SET SCPCT=(+$GET(SCNT("BAD"))/+$GET(SCNT("TOTAL")))*100
+10 ;
+11 ; -- summary info
+12 ;
+13 DO SET(" In order to correct the following active positions with discharged team")
+14 DO SET("assignments, please refer to the documentation for the Patient Team")
+15 DO SET("Position Assignment Review option found in the Stand-alone Options")
+16 DO SET("Section of the PCMM User Guide.")
+17 DO SET(" ")
+18 ;
+19 ;D SET(" ")
+20 ;D SET(" Mode: "_$S(SCMODE=1:"Diagnostic Only",1:"Fix"))
+21 ;
+22 ; -- show teams
+23 DO SET(" Teams Reviewed: "_$SELECT(SCTMLST=1:"All",1:""))
+24 IF SCTMLST=0
Begin DoDot:1
+25 ; -- sort and set
+26 NEW SCTMI,X
+27 SET SCTMI=0
+28 FOR
SET SCTMI=$ORDER(SCTMLST(SCTMI))
if 'SCTMI
QUIT
SET X(SCTMLST(SCTMI)_SCTMI)=SCTMLST(SCTMI)
+29 SET SCTMI=""
+30 FOR
SET SCTMI=$ORDER(X(SCTMI))
if SCTMI=""
QUIT
DO SET(" "_X(SCTMI))
+31 DO SET(" ")
+32 QUIT
End DoDot:1
+33 ;
+34 DO SET(" ")
+35 DO SET(" Patient Team Position Assignments Reviewed: "_$JUSTIFY(+$GET(SCNT("TOTAL")),6))
+36 DO SET(" Number of Assignments with Problems : "_$JUSTIFY(+$GET(SCNT("BAD")),6)_" ("_$JUSTIFY(SCPCT,6,2)_"%)")
+37 DO SET(" ")
+38 DO DASH("=")
+39 QUIT
+40 ;
FINAL ; -- clean up
+1 KILL ^TMP("SCTPTEXT",$JOB)
+2 QUIT
+3 ;
TEXT ; -- set of mm array
+1 NEW SCTMI,SCTPI,SCPTI,SCASDTI,SCPTAI
+2 ;
+3 ; -- sort is by team, position, patient, assign date, position assignment ien
+4 ;
+5 SET SCSTOP=0
+6 SET SCTMI=""
+7 FOR
SET SCTMI=$ORDER(@SCERTMP@(SCTMI))
if SCTMI=""
QUIT
Begin DoDot:1
+8 SET SCTPI=""
FOR
SET SCTPI=$ORDER(@SCERTMP@(SCTMI,SCTPI))
if SCTPI=""
QUIT
Begin DoDot:2
+9 SET SCPTI=""
FOR
SET SCPTI=$ORDER(@SCERTMP@(SCTMI,SCTPI,SCPTI))
if SCPTI=""
QUIT
Begin DoDot:3
+10 SET SCASDTI=0
FOR
SET SCASDTI=$ORDER(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI))
if 'SCASDTI
QUIT
Begin DoDot:4
+11 SET SCTPAI=0
FOR
SET SCTPAI=$ORDER(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI,SCTPAI))
if 'SCTPAI
QUIT
DO PTA
End DoDot:4
End DoDot:3
End DoDot:2
+12 ;
+13 ; -- check if user asked job to stop
+14 IF $$S^%ZTLOAD()
SET (SCSTOP,ZTSTOP)=1
End DoDot:1
if SCSTOP
QUIT
+15 QUIT
+16 ;
PTA ; -- process errors for team position assignment
+1 NEW SCTP,SCTP0,SCTPNM
+2 NEW SCTM,SCTM0,SCTMNM
+3 NEW SCPT,SCPT0,SCPTNM,SCPTID
+4 NEW SCTPA,SCTPA0,SCTPASDT,SCTPUNDT
+5 NEW SCTMA,SCTMA0,SCTMASDT,SCTMUNDT
+6 NEW SCER
+7 ; -- get data
+8 DO DATA^SCMCTPU3(SCTPAI)
+9 ;
+10 ; -- set mm text
+11 DO SET(" Team: "_SCTMNM_" Position: "_SCTPNM)
+12 DO SET(" Patient: "_SCPTNM_" ("_SCPTID_")")
+13 SET SCER=0
+14 FOR
SET SCER=$ORDER(@SCERTMP@(SCTMI,SCTPI,SCPTI,SCASDTI,SCTPAI,SCER))
if 'SCER
QUIT
Begin DoDot:1
+15 IF SCER=1
Begin DoDot:2
+16 DO SET(" Error: Position Assigned Date is BEFORE Team Assigned Date")
+17 DO SET(" Position Assigned Date: "_$$FMTE^XLFDT($EXTRACT(SCTPASDT,1,7),"5Z"))
+18 DO SET(" Team Assigned Date: "_$$FMTE^XLFDT($EXTRACT(SCTMASDT,1,7),"5Z"))
End DoDot:2
+19 ;
+20 IF SCER=2
Begin DoDot:2
+21 DO SET(" Error: Position Unassigned Date is AFTER Team Unassigned Date")
+22 DO SET(" Team Unassigned Date: "_$SELECT(SCTMUNDT=9999999:"<none>",1:$$FMTE^XLFDT($EXTRACT(SCTMUNDT,1,7),"5Z")))
+23 DO SET(" Position Unassigned Date: "_$SELECT(SCTPUNDT=9999999:"<none>",1:$$FMTE^XLFDT($EXTRACT(SCTPUNDT,1,7),"5Z")))
End DoDot:2
+24 ; -- do fix if selected
+25 IF SCMODE=2
DO FIX
End DoDot:1
+26 DO DASH()
+27 QUIT
+28 ;
FIX ; -- fix team position assignment entry (future)
+1 QUIT
+2 ;
SET(X) ;
+1 SET SCLCNT=SCLCNT+1
SET ^TMP("SCTPTEXT",$JOB,SCLCNT,0)=X
+2 QUIT
+3 ;
DASH(CHAR) ; -- send line of CHAR
+1 NEW X
+2 SET $PIECE(X,$EXTRACT($GET(CHAR,"-")),78)=""
+3 DO SET(" "_X)
+4 QUIT
+5 ;
