SCMCTPU3 ;ALB/MJK - Team Position Utility ; 1 SEP 98
;;5.3;Scheduling;**148**;AUG 13,1993
;
EN ; -- main entry point to find pat position assignments w/o team assignment
N SCMODE,SCTMLST,SCTSK
;
; -- ask user which mode (diagnosis vs. fix)
S SCMODE=$$MODE()
IF 'SCMODE G ENQ
;
; -- ask user for teams
IF '$$TEAM() G ENQ
;
; -- queue job to run
S SCTSK=$$QUE()
IF SCTSK'="" D
. W !!,">>> Task#: ",SCTSK
. W !!," This task will send a MailMan message to you containing"
. W !," the results of the position assignment review.",!
D PAUSE
ENQ Q
;
MODE() ; -- get mode from user (1 - diagnostic 2 - fix 0 - abort)
Q 1 ; -- fix mode (2) is a future
;
TEAM() ; -- get teams from user
N Y,DIC,VAUTVB,VAUTSTR,VAUTINI
S VAUTVB="SCTMLST"
S VAUTSTR="Team"
S VAUTNI=2
S DIC="^SCTM(404.51,"
D FIRST^VAUTOMA
Q $S(Y=-1:0,1:1)
;
QUE() ; -- setup task and queue job to run
;D START Q 99999 ; -- for interactive testing
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
S ZTRTN="START^SCMCTPU3"
S ZTDESC="Patient Team Position Assignment Review"
S ZTDTH=$H
S ZTIO=""
F X="SCTMLST(","SCTMLST","SCMODE" S ZTSAVE(X)=""
D ^%ZTLOAD
Q $G(ZTSK)
;
START ; -- entry point for queued job
;
N SCSTOP,SCER,SCERTMP,SCNT
N SCTP,SCTP0,SCTPNM
N SCTM,SCTM0,SCTMNM
N SCPT,SCPT0,SCPTNM,SCPTID
N SCTPA,SCTPA0,SCTPASDT,SCTPUNDT
N SCTMA,SCTMA0,SCTMASDT,SCTMUNDT
;
S SCERTMP=$NA(^TMP("SCTP DANGLERS",$J))
K @SCERTMP
;
; -- is 'all' teams selected build array
IF SCTMLST=1 D
. S SCTM=0
. F S SCTM=$O(^SCTM(404.51,SCTM)) Q:'SCTM S X=$G(^SCTM(404.51,SCTM,0)) S SCTMLST(SCTM)=$P(X,U)
;
; -- loop through entire team position assignment file
S (SCSTOP,SCTPA)=0
F S SCTPA=$O(^SCPT(404.43,SCTPA)) Q:'SCTPA D Q:SCSTOP
. IF $$S^%ZTLOAD() S (SCSTOP,ZTSTOP)=1 Q
. N SCERAR
. ;
. ; -- get data
. D DATA(SCTPA)
. ;
. ; -- quit if team not selected by user
. IF '$D(SCTMLST(SCTM)) Q
. ;
. D CNT("TOTAL")
. ;
. ; -- if postion assigned date >= team assigned date
. ; and
. ; position unassigned date <= team unassigned date
. ; then entry is good
. ;
. ; else
. ; process error
. ;
. IF SCTPASDT>SCTMASDT!(SCTPASDT=SCTMASDT) D
. . IF SCTPUNDT<SCTMUNDT!(SCTPUNDT=SCTMUNDT) D
. . . D CNT("OK")
. . . Q
. . ; -- position unassign date > team unassign date
. . ELSE D
. . . D ERR(2)
. . . Q
. . Q
. ; -- position assign date < team assign date
. ELSE D
. . D ERR(1)
. . Q
. ;
. IF $O(SCERAR(0)) D CNT("BAD"),SET
. ; -- check if user asked job to stop
. Q
;
IF 'SCSTOP D BULL^SCMCTPU4
;
K @SCERTMP
Q
;
CNT(TYPE) ; -- set counter
S SCNT(TYPE)=$G(SCNT(TYPE))+1
Q
;
ERR(NUMBER) ; -- set error array
S SCERAR(NUMBER)=""
Q
;
SET ; -- set tmp for report
N SCER
S SCER=0
F S SCER=$O(SCERAR(SCER)) Q:'SCER D
. S @SCERTMP@(SCTMNM_SCTM,SCTPNM_SCTP,SCPTNM_SCPT,SCTPASDT,SCTPA,SCER)=""
Q
;
DATA(SCTPA) ; -- get team, position, tm pos assign, tm assignment & patient data
; input: SCPTA := ien to patient team position assignment (404.43)
;
; -- Team Position Assignment (TPA) data
S SCTPA0=$G(^SCPT(404.43,SCTPA,0))
S SCTPASDT=+$P(SCTPA0,U,3)
S SCTPUNDT=$S($P(SCTPA0,U,4):$P(SCTPA0,U,4),1:9999999)
;
; -- Team Position (TP) data
S SCTP=+$P(SCTPA0,U,2)
S SCTP0=$G(^SCTM(404.57,SCTP,0))
S SCTPNM=$P(SCTP0,U)
;
; -- TeaM Assignment (TMA) data
S SCTMA=+SCTPA0
S SCTMA0=$G(^SCPT(404.42,SCTMA,0))
S SCTMASDT=+$P(SCTMA0,U,2)
S SCTMUNDT=$S($P(SCTMA0,U,9):$P(SCTMA0,U,9),1:9999999)
;
; -- TeaM (TM) data
S SCTM=+$P(SCTMA0,U,3)
S SCTM0=$G(^SCTM(404.51,SCTM,0))
S SCTMNM=$P(SCTM0,U)
;
; -- PaTient (PT) data
S SCPT=+SCTMA0
S SCPT0=$G(^DPT(SCPT,0))
S SCPTNM=$P(SCPT0,U)
N DFN,VA
S DFN=SCPT D PID^VADPT6
S SCPTID=VA("BID")
Q
;
PAUSE ; -- pause
N DIR,Y
S DIR(0)="EA"
S DIR("A")=">>> Press RETURN to continue: "
D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTPU3 3991 printed Sep 23, 2025@20:17:49 Page 2
SCMCTPU3 ;ALB/MJK - Team Position Utility ; 1 SEP 98
+1 ;;5.3;Scheduling;**148**;AUG 13,1993
+2 ;
EN ; -- main entry point to find pat position assignments w/o team assignment
+1 NEW SCMODE,SCTMLST,SCTSK
+2 ;
+3 ; -- ask user which mode (diagnosis vs. fix)
+4 SET SCMODE=$$MODE()
+5 IF 'SCMODE
GOTO ENQ
+6 ;
+7 ; -- ask user for teams
+8 IF '$$TEAM()
GOTO ENQ
+9 ;
+10 ; -- queue job to run
+11 SET SCTSK=$$QUE()
+12 IF SCTSK'=""
Begin DoDot:1
+13 WRITE !!,">>> Task#: ",SCTSK
+14 WRITE !!," This task will send a MailMan message to you containing"
+15 WRITE !," the results of the position assignment review.",!
End DoDot:1
+16 DO PAUSE
ENQ QUIT
+1 ;
MODE() ; -- get mode from user (1 - diagnostic 2 - fix 0 - abort)
+1 ; -- fix mode (2) is a future
QUIT 1
+2 ;
TEAM() ; -- get teams from user
+1 NEW Y,DIC,VAUTVB,VAUTSTR,VAUTINI
+2 SET VAUTVB="SCTMLST"
+3 SET VAUTSTR="Team"
+4 SET VAUTNI=2
+5 SET DIC="^SCTM(404.51,"
+6 DO FIRST^VAUTOMA
+7 QUIT $SELECT(Y=-1:0,1:1)
+8 ;
QUE() ; -- setup task and queue job to run
+1 ;D START Q 99999 ; -- for interactive testing
+2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
+3 SET ZTRTN="START^SCMCTPU3"
+4 SET ZTDESC="Patient Team Position Assignment Review"
+5 SET ZTDTH=$HOROLOG
+6 SET ZTIO=""
+7 FOR X="SCTMLST(","SCTMLST","SCMODE"
SET ZTSAVE(X)=""
+8 DO ^%ZTLOAD
+9 QUIT $GET(ZTSK)
+10 ;
START ; -- entry point for queued job
+1 ;
+2 NEW SCSTOP,SCER,SCERTMP,SCNT
+3 NEW SCTP,SCTP0,SCTPNM
+4 NEW SCTM,SCTM0,SCTMNM
+5 NEW SCPT,SCPT0,SCPTNM,SCPTID
+6 NEW SCTPA,SCTPA0,SCTPASDT,SCTPUNDT
+7 NEW SCTMA,SCTMA0,SCTMASDT,SCTMUNDT
+8 ;
+9 SET SCERTMP=$NAME(^TMP("SCTP DANGLERS",$JOB))
+10 KILL @SCERTMP
+11 ;
+12 ; -- is 'all' teams selected build array
+13 IF SCTMLST=1
Begin DoDot:1
+14 SET SCTM=0
+15 FOR
SET SCTM=$ORDER(^SCTM(404.51,SCTM))
if 'SCTM
QUIT
SET X=$GET(^SCTM(404.51,SCTM,0))
SET SCTMLST(SCTM)=$PIECE(X,U)
End DoDot:1
+16 ;
+17 ; -- loop through entire team position assignment file
+18 SET (SCSTOP,SCTPA)=0
+19 FOR
SET SCTPA=$ORDER(^SCPT(404.43,SCTPA))
if 'SCTPA
QUIT
Begin DoDot:1
+20 IF $$S^%ZTLOAD()
SET (SCSTOP,ZTSTOP)=1
QUIT
+21 NEW SCERAR
+22 ;
+23 ; -- get data
+24 DO DATA(SCTPA)
+25 ;
+26 ; -- quit if team not selected by user
+27 IF '$DATA(SCTMLST(SCTM))
QUIT
+28 ;
+29 DO CNT("TOTAL")
+30 ;
+31 ; -- if postion assigned date >= team assigned date
+32 ; and
+33 ; position unassigned date <= team unassigned date
+34 ; then entry is good
+35 ;
+36 ; else
+37 ; process error
+38 ;
+39 IF SCTPASDT>SCTMASDT!(SCTPASDT=SCTMASDT)
Begin DoDot:2
+40 IF SCTPUNDT<SCTMUNDT!(SCTPUNDT=SCTMUNDT)
Begin DoDot:3
+41 DO CNT("OK")
+42 QUIT
End DoDot:3
+43 ; -- position unassign date > team unassign date
+44 IF '$TEST
Begin DoDot:3
+45 DO ERR(2)
+46 QUIT
End DoDot:3
+47 QUIT
End DoDot:2
+48 ; -- position assign date < team assign date
+49 IF '$TEST
Begin DoDot:2
+50 DO ERR(1)
+51 QUIT
End DoDot:2
+52 ;
+53 IF $ORDER(SCERAR(0))
DO CNT("BAD")
DO SET
+54 ; -- check if user asked job to stop
+55 QUIT
End DoDot:1
if SCSTOP
QUIT
+56 ;
+57 IF 'SCSTOP
DO BULL^SCMCTPU4
+58 ;
+59 KILL @SCERTMP
+60 QUIT
+61 ;
CNT(TYPE) ; -- set counter
+1 SET SCNT(TYPE)=$GET(SCNT(TYPE))+1
+2 QUIT
+3 ;
ERR(NUMBER) ; -- set error array
+1 SET SCERAR(NUMBER)=""
+2 QUIT
+3 ;
SET ; -- set tmp for report
+1 NEW SCER
+2 SET SCER=0
+3 FOR
SET SCER=$ORDER(SCERAR(SCER))
if 'SCER
QUIT
Begin DoDot:1
+4 SET @SCERTMP@(SCTMNM_SCTM,SCTPNM_SCTP,SCPTNM_SCPT,SCTPASDT,SCTPA,SCER)=""
End DoDot:1
+5 QUIT
+6 ;
DATA(SCTPA) ; -- get team, position, tm pos assign, tm assignment & patient data
+1 ; input: SCPTA := ien to patient team position assignment (404.43)
+2 ;
+3 ; -- Team Position Assignment (TPA) data
+4 SET SCTPA0=$GET(^SCPT(404.43,SCTPA,0))
+5 SET SCTPASDT=+$PIECE(SCTPA0,U,3)
+6 SET SCTPUNDT=$SELECT($PIECE(SCTPA0,U,4):$PIECE(SCTPA0,U,4),1:9999999)
+7 ;
+8 ; -- Team Position (TP) data
+9 SET SCTP=+$PIECE(SCTPA0,U,2)
+10 SET SCTP0=$GET(^SCTM(404.57,SCTP,0))
+11 SET SCTPNM=$PIECE(SCTP0,U)
+12 ;
+13 ; -- TeaM Assignment (TMA) data
+14 SET SCTMA=+SCTPA0
+15 SET SCTMA0=$GET(^SCPT(404.42,SCTMA,0))
+16 SET SCTMASDT=+$PIECE(SCTMA0,U,2)
+17 SET SCTMUNDT=$SELECT($PIECE(SCTMA0,U,9):$PIECE(SCTMA0,U,9),1:9999999)
+18 ;
+19 ; -- TeaM (TM) data
+20 SET SCTM=+$PIECE(SCTMA0,U,3)
+21 SET SCTM0=$GET(^SCTM(404.51,SCTM,0))
+22 SET SCTMNM=$PIECE(SCTM0,U)
+23 ;
+24 ; -- PaTient (PT) data
+25 SET SCPT=+SCTMA0
+26 SET SCPT0=$GET(^DPT(SCPT,0))
+27 SET SCPTNM=$PIECE(SCPT0,U)
+28 NEW DFN,VA
+29 SET DFN=SCPT
DO PID^VADPT6
+30 SET SCPTID=VA("BID")
+31 QUIT
+32 ;
PAUSE ; -- pause
+1 NEW DIR,Y
+2 SET DIR(0)="EA"
+3 SET DIR("A")=">>> Press RETURN to continue: "
+4 DO ^DIR
+5 QUIT
