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