- 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 Jan 18, 2025@03:42:37 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 ;