SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98 ; 5/14/12 1:54pm
;;5.3;Scheduling;**148,177,524,563**;AUG 13, 1993;Build 45
;
QUE() ; -- queue mass unassignment
;D START Q 99999 ; -- for interactive testing
N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
S ZTRTN="START^SCMCMU2"
S ZTDESC=VALM("TITLE")
S ZTDTH=$H
S ZTIO=""
F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)=""
F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)=""
D ^%ZTLOAD
Q $G(ZTSK)
;
START ; -- entry point for task
; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT
;
N SCTOP,SCUNCNT,SCASCNT,SCOK
S SCUNCNT=0
S SCASCNT=SCSELCNT
;
; -- lock top node
IF SCMUTYPE="T" D
. S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0))
ELSE IF SCMUTYPE="P" D
. S SCTOP=$NA(^SCTM(404.57,+SCPOS,0))
D LOCK(SCTOP)
;
; -- use tmp data brought in by TaskMan
N SCPTSEL,SCPTINFO
S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED"))
S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO"))
;
N SCOKAR,SCBADAR,SCERRAR,SCPTTP
S SCOKAR=$NA(^TMP("SCMU",$J,"OK"))
S SCBADAR=$NA(^TMP("SCMU",$J,"BAD"))
S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR"))
S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION"))
K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
;
N SCNT,SCNODE,SCPTX
;
; -- create patient-position array for team processing
IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP)
;
S SCNT=0
F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D
. ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing
. S SCPTX=$G(@SCPTINFO@(SCNT))
. IF SCPTX="" Q
. IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX)
. ;
. IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX)
. ;
. ; -- if successful
. IF SCOK D
. . S @SCOKAR@(SCNT)=""
. . S SCUNCNT=SCUNCNT+1
. . S SCASCNT=SCASCNT-1
. ;
. ; -- if not sucessful
. ELSE D
. . S @SCBADAR@(SCNT)=""
;
; -- unlock top node
D UNLOCK(SCTOP)
;
; -- send results
D BULL^SCMCMU4
;
K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
K @SCPTSEL,@SCPTINFO
Q
;
; **** May want to eventually combine TMDIS & TPDIS tags ****
;
TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient
; input: SCDATE := effective date
; SCTEAM := ien of TEAM entry (404.51)
; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
; SCPTX := format defined by output of $$PTTM^SCAPMC2
;
N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
;
S SCOK=1
S SCERRS="SCERRLST"
;
S DFN=+SCPTX
S SCIEN=+$P(SCPTX,U,3)
S SCNODE=$NA(^SCPT(404.42,SCIEN,0))
S SCASDT=+$P(SCPTX,U,4)
S SCUNDT=+$P(SCPTX,U,5)
;
; -- unassign from positions first
S SCPOS=0
F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK
. S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS)))
;
IF 'SCOK D
. S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient."
. S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position."
;
IF SCOK D
. ; -- if assignment date is in future then delete
. IF SCASDT>DT,SCASDT>SCDATE D Q
. . N DA,DIK
. . S DA=SCIEN,DIK="^SCPT(404.42,"
. . D LOCK(SCNODE)
. . D ^DIK
. . D UNLOCK(SCNODE)
. . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted."
. . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
. . Q
. ;
. ; -- if assignment date is after effective date but before today
. IF SCASDT>SCDATE,SCASDT<DT D Q
. . S SCOK=0
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Assignment date is after effective date but before today."
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
. . Q
. ;
. ; -- if unassignment date is after effective date but before today
. IF SCUNDT>SCDATE,SCUNDT<DT D Q
. . S SCOK=0
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Unassignment date is after effective date but before today."
. . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" Entry#: "_SCIEN
. . Q
. ;
. ; -- make change
. K @SCERRS
. S SCOK=$$INPTTM^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
. D UNLOCK(SCNODE)
. M @SCERRAR@(SCNT,"TEAM",SCTEAM)=SCERRLST
. K @SCERRS
. IF SCOK D
. . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=""
. ;
. ; -- set message if unassigned date changed
. IF SCOK,SCUNDT>SCDATE D
. . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed."
. . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
;
Q SCOK
;
TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient
; input: SCDATE := effective date
; SCTEAM := ien of TEAM POSITION entry (404.57)
; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
; SCPTX := format defined by output of $$PTTP^SCAPMC2
;
N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
S SCASDT=+$P(SCPTX,U,4)
S SCUNDT=+$P(SCPTX,U,5)
;
S SCOK=1
S SCERRS="SCERRLST"
;
S DFN=+SCPTX
S SCIEN=+$P(SCPTX,U,3)
S SCNODE=$NA(^SCPT(404.43,SCIEN,0))
S SCASDT=+$P(SCPTX,U,4)
S SCUNDT=+$P(SCPTX,U,5)
;
; if assignment date is in future then delete
IF SCOK D
. ; -- if assignment date is in future then delete
. IF SCASDT>DT,SCASDT>SCDATE D Q
. . N DA,DIE,DIK,DR D LOCK(SCNODE) ; Call Lock subroutine prior to DIE Call SD*5.3*563
. . S DA=SCIEN,DIE="^SCPT(404.43,",DR=".04///"_DT D ^DIE ; og/sd/524
. . ;Set variables DIK and DA after DIE call to preserve value SD*5.3*563
. . S DIK="^SCPT(404.43,",DA=SCIEN D ^DIK
. . D UNLOCK(SCNODE)
. . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted."
. . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
. . Q
. ;
. ; -- if assignment date is after effective date but before today
. IF SCASDT>SCDATE,SCASDT<DT D Q
. . S SCOK=0
. . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
. . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Assignment date is after effective date but before today."
. . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
. . Q
. ;
. ; -- if unassignment date is after effective date but before today
. IF SCUNDT>SCDATE,SCUNDT<DT D Q
. . S SCOK=0
. . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
. . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Unassignment date is after effective date but before today."
. . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" ("_SCIEN_")"
. . Q
. ;
. K @SCERRS
. D LOCK(SCNODE)
. S SCOK=$$INPTTP^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
. D UNLOCK(SCNODE)
. M @SCERRAR@(SCNT,"POS",SCPOS)=SCERRLST
. K @SCERRS
. IF SCOK D
. . S @SCOKAR@(SCNT,"POS",SCPOS,1)=""
. ;
. ; -- set message if unassigned date changed
. IF SCOK,SCUNDT>SCDATE D
. . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed."
. . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
. . Q
;
IF SCOK D
. S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS)
. Q
;
TPDISQ Q SCOK
;
CLDIS(SCPOS) ; -- discharge from clinic
N SCPOS0,SCCLN,SCREA,SCRET
S SCRET=""
;
; -- if user did not request clinic discharge, quit
IF '$G(SCTPDIS(+SCPOS)) G CLDISQ
;
S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
S SCCLN=$P(SCPOS0,U,9)
IF SCCLN D
. S SCREA="Team position mass discharge"
. S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA)
. Q
ELSE D
. S SCRET="0^No clinic assignment to position"
. Q
;
CLDISQ Q SCRET
;
LOCK(NODE) ; -- lock node
F L +@NODE:5 IF $T Q
Q
;
UNLOCK(NODE) ; -- unlock node
L -@NODE
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMU2 8117 printed Nov 22, 2024@17:50:59 Page 2
SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98 ; 5/14/12 1:54pm
+1 ;;5.3;Scheduling;**148,177,524,563**;AUG 13, 1993;Build 45
+2 ;
QUE() ; -- queue mass unassignment
+1 ;D START Q 99999 ; -- for interactive testing
+2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
+3 SET ZTRTN="START^SCMCMU2"
+4 SET ZTDESC=VALM("TITLE")
+5 SET ZTDTH=$HOROLOG
+6 SET ZTIO=""
+7 FOR X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT"
SET ZTSAVE(X)=""
+8 FOR X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO"","
SET ZTSAVE(X)=""
+9 DO ^%ZTLOAD
+10 QUIT $GET(ZTSK)
+11 ;
START ; -- entry point for task
+1 ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT
+2 ;
+3 NEW SCTOP,SCUNCNT,SCASCNT,SCOK
+4 SET SCUNCNT=0
+5 SET SCASCNT=SCSELCNT
+6 ;
+7 ; -- lock top node
+8 IF SCMUTYPE="T"
Begin DoDot:1
+9 SET SCTOP=$NAME(^SCTM(404.51,+SCTEAM,0))
End DoDot:1
+10 IF '$TEST
IF SCMUTYPE="P"
Begin DoDot:1
+11 SET SCTOP=$NAME(^SCTM(404.57,+SCPOS,0))
End DoDot:1
+12 DO LOCK(SCTOP)
+13 ;
+14 ; -- use tmp data brought in by TaskMan
+15 NEW SCPTSEL,SCPTINFO
+16 SET SCPTSEL=$NAME(^TMP("SCMU",$JOB,"SELECTED"))
+17 SET SCPTINFO=$NAME(^TMP("SCMU",$JOB,"PATIENT INFO"))
+18 ;
+19 NEW SCOKAR,SCBADAR,SCERRAR,SCPTTP
+20 SET SCOKAR=$NAME(^TMP("SCMU",$JOB,"OK"))
+21 SET SCBADAR=$NAME(^TMP("SCMU",$JOB,"BAD"))
+22 SET SCERRAR=$NAME(^TMP("SCMU",$JOB,"ERROR"))
+23 SET SCPTTP=$NAME(^TMP("SCMU",$JOB,"PATIENT-POSITION"))
+24 KILL @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
+25 ;
+26 NEW SCNT,SCNODE,SCPTX
+27 ;
+28 ; -- create patient-position array for team processing
+29 IF SCMUTYPE="T"
DO PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP)
+30 ;
+31 SET SCNT=0
+32 FOR
SET SCNT=$ORDER(@SCPTSEL@(SCNT))
if 'SCNT
QUIT
Begin DoDot:1
+33 ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing
+34 SET SCPTX=$GET(@SCPTINFO@(SCNT))
+35 IF SCPTX=""
QUIT
+36 IF SCMUTYPE="T"
SET SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX)
+37 ;
+38 IF SCMUTYPE="P"
SET SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX)
+39 ;
+40 ; -- if successful
+41 IF SCOK
Begin DoDot:2
+42 SET @SCOKAR@(SCNT)=""
+43 SET SCUNCNT=SCUNCNT+1
+44 SET SCASCNT=SCASCNT-1
End DoDot:2
+45 ;
+46 ; -- if not sucessful
+47 IF '$TEST
Begin DoDot:2
+48 SET @SCBADAR@(SCNT)=""
End DoDot:2
End DoDot:1
+49 ;
+50 ; -- unlock top node
+51 DO UNLOCK(SCTOP)
+52 ;
+53 ; -- send results
+54 DO BULL^SCMCMU4
+55 ;
+56 KILL @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
+57 KILL @SCPTSEL,@SCPTINFO
+58 QUIT
+59 ;
+60 ; **** May want to eventually combine TMDIS & TPDIS tags ****
+61 ;
TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient
+1 ; input: SCDATE := effective date
+2 ; SCTEAM := ien of TEAM entry (404.51)
+3 ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
+4 ; SCPTX := format defined by output of $$PTTM^SCAPMC2
+5 ;
+6 NEW SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
+7 ;
+8 SET SCOK=1
+9 SET SCERRS="SCERRLST"
+10 ;
+11 SET DFN=+SCPTX
+12 SET SCIEN=+$PIECE(SCPTX,U,3)
+13 SET SCNODE=$NAME(^SCPT(404.42,SCIEN,0))
+14 SET SCASDT=+$PIECE(SCPTX,U,4)
+15 SET SCUNDT=+$PIECE(SCPTX,U,5)
+16 ;
+17 ; -- unassign from positions first
+18 SET SCPOS=0
+19 FOR
SET SCPOS=$ORDER(@SCPTTP@(DFN,SCPOS))
if 'SCPOS
QUIT
Begin DoDot:1
+20 SET SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$GET(@SCPTTP@(DFN,SCPOS)))
End DoDot:1
if 'SCOK
QUIT
+21 ;
+22 IF 'SCOK
Begin DoDot:1
+23 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient."
+24 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position."
End DoDot:1
+25 ;
+26 IF SCOK
Begin DoDot:1
+27 ; -- if assignment date is in future then delete
+28 IF SCASDT>DT
IF SCASDT>SCDATE
Begin DoDot:2
+29 NEW DA,DIK
+30 SET DA=SCIEN
SET DIK="^SCPT(404.42,"
+31 DO LOCK(SCNODE)
+32 DO ^DIK
+33 DO UNLOCK(SCNODE)
+34 SET @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted."
+35 SET @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
+36 QUIT
End DoDot:2
QUIT
+37 ;
+38 ; -- if assignment date is after effective date but before today
+39 IF SCASDT>SCDATE
IF SCASDT<DT
Begin DoDot:2
+40 SET SCOK=0
+41 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
+42 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Assignment date is after effective date but before today."
+43 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
+44 QUIT
End DoDot:2
QUIT
+45 ;
+46 ; -- if unassignment date is after effective date but before today
+47 IF SCUNDT>SCDATE
IF SCUNDT<DT
Begin DoDot:2
+48 SET SCOK=0
+49 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
+50 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Unassignment date is after effective date but before today."
+51 SET @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" Entry#: "_SCIEN
+52 QUIT
End DoDot:2
QUIT
+53 ;
+54 ; -- make change
+55 KILL @SCERRS
+56 SET SCOK=$$INPTTM^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
+57 DO UNLOCK(SCNODE)
+58 MERGE @SCERRAR@(SCNT,"TEAM",SCTEAM)=SCERRLST
+59 KILL @SCERRS
+60 IF SCOK
Begin DoDot:2
+61 SET @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=""
End DoDot:2
+62 ;
+63 ; -- set message if unassigned date changed
+64 IF SCOK
IF SCUNDT>SCDATE
Begin DoDot:2
+65 SET @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed."
+66 SET @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
End DoDot:2
End DoDot:1
+67 ;
+68 QUIT SCOK
+69 ;
TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient
+1 ; input: SCDATE := effective date
+2 ; SCTEAM := ien of TEAM POSITION entry (404.57)
+3 ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
+4 ; SCPTX := format defined by output of $$PTTP^SCAPMC2
+5 ;
+6 NEW SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
+7 SET SCASDT=+$PIECE(SCPTX,U,4)
+8 SET SCUNDT=+$PIECE(SCPTX,U,5)
+9 ;
+10 SET SCOK=1
+11 SET SCERRS="SCERRLST"
+12 ;
+13 SET DFN=+SCPTX
+14 SET SCIEN=+$PIECE(SCPTX,U,3)
+15 SET SCNODE=$NAME(^SCPT(404.43,SCIEN,0))
+16 SET SCASDT=+$PIECE(SCPTX,U,4)
+17 SET SCUNDT=+$PIECE(SCPTX,U,5)
+18 ;
+19 ; if assignment date is in future then delete
+20 IF SCOK
Begin DoDot:1
+21 ; -- if assignment date is in future then delete
+22 IF SCASDT>DT
IF SCASDT>SCDATE
Begin DoDot:2
+23 ; Call Lock subroutine prior to DIE Call SD*5.3*563
NEW DA,DIE,DIK,DR
DO LOCK(SCNODE)
+24 ; og/sd/524
SET DA=SCIEN
SET DIE="^SCPT(404.43,"
SET DR=".04///"_DT
DO ^DIE
+25 ;Set variables DIK and DA after DIE call to preserve value SD*5.3*563
+26 SET DIK="^SCPT(404.43,"
SET DA=SCIEN
DO ^DIK
+27 DO UNLOCK(SCNODE)
+28 SET @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted."
+29 SET @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
+30 QUIT
End DoDot:2
QUIT
+31 ;
+32 ; -- if assignment date is after effective date but before today
+33 IF SCASDT>SCDATE
IF SCASDT<DT
Begin DoDot:2
+34 SET SCOK=0
+35 SET @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
+36 SET @SCERRAR@(SCNT,"POS",SCPOS,2)="Assignment date is after effective date but before today."
+37 SET @SCERRAR@(SCNT,"POS",SCPOS,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
+38 QUIT
End DoDot:2
QUIT
+39 ;
+40 ; -- if unassignment date is after effective date but before today
+41 IF SCUNDT>SCDATE
IF SCUNDT<DT
Begin DoDot:2
+42 SET SCOK=0
+43 SET @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
+44 SET @SCERRAR@(SCNT,"POS",SCPOS,2)="Unassignment date is after effective date but before today."
+45 SET @SCERRAR@(SCNT,"POS",SCPOS,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" ("_SCIEN_")"
+46 QUIT
End DoDot:2
QUIT
+47 ;
+48 KILL @SCERRS
+49 DO LOCK(SCNODE)
+50 SET SCOK=$$INPTTP^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
+51 DO UNLOCK(SCNODE)
+52 MERGE @SCERRAR@(SCNT,"POS",SCPOS)=SCERRLST
+53 KILL @SCERRS
+54 IF SCOK
Begin DoDot:2
+55 SET @SCOKAR@(SCNT,"POS",SCPOS,1)=""
End DoDot:2
+56 ;
+57 ; -- set message if unassigned date changed
+58 IF SCOK
IF SCUNDT>SCDATE
Begin DoDot:2
+59 SET @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed."
+60 SET @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
+61 QUIT
End DoDot:2
End DoDot:1
+62 ;
+63 IF SCOK
Begin DoDot:1
+64 SET @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS)
+65 QUIT
End DoDot:1
+66 ;
TPDISQ QUIT SCOK
+1 ;
CLDIS(SCPOS) ; -- discharge from clinic
+1 NEW SCPOS0,SCCLN,SCREA,SCRET
+2 SET SCRET=""
+3 ;
+4 ; -- if user did not request clinic discharge, quit
+5 IF '$GET(SCTPDIS(+SCPOS))
GOTO CLDISQ
+6 ;
+7 SET SCPOS0=$GET(^SCTM(404.57,SCPOS,0))
+8 SET SCCLN=$PIECE(SCPOS0,U,9)
+9 IF SCCLN
Begin DoDot:1
+10 SET SCREA="Team position mass discharge"
+11 SET SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA)
+12 QUIT
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 SET SCRET="0^No clinic assignment to position"
+15 QUIT
End DoDot:1
+16 ;
CLDISQ QUIT SCRET
+1 ;
LOCK(NODE) ; -- lock node
+1 FOR
LOCK +@NODE:5
IF $TEST
QUIT
+2 QUIT
+3 ;
UNLOCK(NODE) ; -- unlock node
+1 LOCK -@NODE
+2 QUIT
+3 ;
