Routine: SCMCMU2

SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98

 ;;5.3;Scheduling;**148,177,524,1015**;AUG 13, 1993;Build 21

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

 ; **** 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

 . . S DA=SCIEN,(DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE  ; og/sd/524

 . . D LOCK(SCNODE)

 . . 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

UNLOCK(NODE) ; -- unlock node

 L -@NODE

SCMCMU2   ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98

 +1       ;;5.3;Scheduling;**148,177,524,1015**;AUG 13, 1993;Build 21

 +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                           NEW DA,DIE,DIK,DR

 +24      ; og/sd/524

                               SET DA=SCIEN

                               SET (DIE,DIK)="^SCPT(404.43,"

                               SET DR=".04///"_DT

                               DO ^DIE

 +25                           DO LOCK(SCNODE)

 +26                           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       ;

SCMCMU2.m