SCMCQK2.m

SCMCQK2 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002  12:10 PM

 ;;5.3;Scheduling;**297,1015**;AUG 13, 1993;Build 21

 ;

DSPL ;

 N LP,SCD,SCPOS

 S SCTOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")

 S SCOK=$$TPPT^SCAPMC(DFN,"","","","","","","SCPOS","SCBKERR")

  ;

  ;loop through positions only getting the ones associated with the team

  ;and that are active.

  ;

  F LP=0:0 S LP=$O(SCPOS(LP)) Q:'LP  D

  .I $P(SCPOS(LP),U,6)]"" K SCPOS(LP) Q

  .S SCPOS("T",$P(SCPOS(LP),U,3),+SCPOS(LP))=SCPOS(LP)

 S CNT=0,POS=0

 F LP=0:0 S LP=$O(SCD(LP)) Q:'LP  S A=SCD(LP) I '$P(A,U,8) D

 .I 'CNT W !!,"NON PC ASSIGNMENTS",!

 .S CNT=CNT+1 W !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2) S DATA(CNT)=+A

 .F I=0:0 S I=$O(SCPOS("T",+A,I)) Q:'I  D

 ..I $P(DATA(CNT),U,2) S CNT=CNT+1

 ..S B=SCPOS("T",+A,I)

 ..S DATA(CNT)=(+A)_U_(+B),POS=1

 ..S SCPR=$$GETPRTP^SCAPMCU2(+B,DT),RES=$$NEWPERSN^SCMCGU(+SCPR,"SCPR")

 ..W:$X>76 !,CNT,?4,"Non-PC Team: "_$P(A,U,2),?48,"Phone: "_$P($G(^SCTM(404.51,+A,0)),U,2)

 ..W !,?7,"Provider: "_$P(SCPR,U,2),?45,"Position: "_$P(B,U,2)_"       "

 ..W !,?10,"Pager: "_$P($G(SCPR(+SCPR)),U,5),?48,"Phone: ",$P($G(SCPR(+SCPR)),U,2),?77," "

 I 'CNT W !,"No active NON PC ASSIGNMENTS for this patient",!

 Q

NPC N SCDT,SCER1,SCD,SCPOS

 D DSPL

 S DIR(0)="SO^0:NONE;1:TEAM ASSIGNMENT;"_$S(CNT:"2:POSITION ASSIGNMENT;3:UNASSIGNMENT;",1:"")

 S DIR("B")=1

 D ^DIR

 I Y=0 Q

 I Y=U Q

 I Y=1 D ASTM G NPC

READ S:CNT=1 X=1 I CNT>1 W !,"Select 1-"_CNT_": " R X:DTIME  Q:X=U  S X=+X I X>CNT!X<1 G READ

 I Y=3 S DATA=DATA(+X) S SCTPSTAT=1,SCTP=+$P(DATA,U,2),SCTM=+DATA D UNTP:SCTP,UNTM:'SCTP G NPC

 S DATA=DATA(+X),SCTM=+DATA S SCSELECT=$$SELPOS() G NPC:'$L(SCSELECT) D ASTP G NPC

 Q

UNTP ;unassign patient from position

 IF '$G(SCTP) W !,"No position defined" Q

 N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 S OK=0

 W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"

 S SCDISCH=$$DATE("D")

 G:SCDISCH<1 QTUNTP

 G:'$$CONFIRM() QTUNTP

 S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)

 G:OK'>0 QTUNTP

 S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)

QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.")

 Q

 ;

 ;

UNTM ;

 ;assign patient from non pc team (and pc position if possible)

 N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3

 S OK=0

 W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"

 W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"

 S SCDISCH=$$DATE("D")

 G:SCDISCH<1 QTUNTM

 G:'$$CONFIRM() QTUNTM

 IF 'SCTPSTAT D  G:OK2'>0 QTUNTM

 .W !,"Unassigned."

 .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)

 .IF OK2>0 D

 ..W "made."

 ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)

 S OK3=$$ALLPOS^SCMCQK1()

 IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D

 .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)

 ELSE  D

 . W !,"Future/Current Patient-Position Assignment exists"

QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.")

 Q

 ;

ASTM ;assign patient to team

 N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 S OK=0

 W !!,"About to Assign "_$$NAME(DFN)_" to a non primary care team"

 I $$SC^SCMCQK1(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"

 S DIC="^SCTM(404.51,"

 S DIC(0)="AEMQZ"

 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT) I $$NEW^SCMCQK2()"

 ;  - select from active teams that can not be PC Teams

 D ^DIC

 G:Y<1 QTASTM

 S SCTM=+Y

 S SCASSDT=$$DATE("A")

 G:SCASSDT<1 QTASTM

 S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)

 S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8)

 I SCTMCT'<SCTMMAX  D  G QTASTM:'$$YESNO2()

 .W !,"This assignment will reach or exceeded the maximum set for this team."

 .W !,"Currently assigned: "_SCTMCT

 .W !,"Maximum set for team: "_SCTMMAX

 I SCTMCT<SCTMMAX,'$$CONFIRM() G QTASTM

 S SCTM=+Y

 ;setup fields

 ;S SCTMFLDS(.08)=1 ;primary care assignment

 S SCTMFLDS(.11)=$G(DUZ,.5)

 D NOW^%DTC S SCTMFLDS(.12)=%

 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME") D

 .S SCSELECT=$$SELPOS()

 .D:$L(SCSELECT) ASTP ;prompt for position prompt

 .S OK=1

QTASTM W !,"Team Assignment "_$S(OK:"made",1:"NOT made.")

 Q

ASTP ;assign patient to practitioner

 N DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 S OK=0

 W !!,"About to Assign "_$$NAME(DFN)_" to non PC Position Assignment"

 I $$SC^SCMCQK1(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************"

 ;lookup to display only position and [practitioner]

 IF SCSELECT="PRACT" D

 .S DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""

 .S DIC("A")="POSITION's Current PRACTITIONER: "

 .S DIC="^SCTM(404.52,"

 .;Must be from team, must be active,must not have future inactivation

 .S DIC("S")="I $$PRACSCR^SCMCQK2(Y)"

 .S D="C"

 ELSE  D

 .S DIC="^SCTM(404.57,"

 .S D="B"

 .S DIC("A")="POSITION's Name: "

 .S DIC("S")="I $$POSSCR^SCMCQK2(Y)"

 S DIC(0)="AEMQZ"

 D MIX^DIC1

 G:Y<1 QTASTP

 IF SCSELECT="PRACT" D

 .S SCTP=$P(Y,U,2)

 ELSE  D

 .S SCTP=$P(Y,U,1)

 S SCASSDT=$$DATE("A")

 G:SCASSDT<1 QTASTP

 S SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP),SCTMMAX=+$P($G(^SCTM(404.57,SCTP,0)),U,8)

 I SCTMCT'<SCTMMAX D  G QTASTP:'$$YESNO2

 .W !,"This assignment will reach or exceeded the maximum set for this position."

 .W !,"Currently assigned: "_SCTMCT

 .W !,"Maximum set for position: "_SCTMMAX

 G:'$$CONFIRM() QTASTP

 ;setup fields

 S SCTPFLDS(.03)=SCASSDT

 ;S SCTPFLDS(.05)=1 ;pc pract role

 S SCTPFLDS(.06)=$G(DUZ,.5)

 D NOW^%DTC S SCTPFLDS(.07)=%

 IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0) D

 .S OK=1

 .S SCCL=$P(^SCTM(404.57,SCTP,0),U,9)

QTASTP W !,"Position Assignment "_$S(OK:"made",1:"NOT made.")

 Q

NAME(DFN) ;return patient name

 Q $P($G(^DPT(DFN,0)),U,1)

 ;

POSITION(SCTP) ;return position name

 Q $P($G(^SCTM(404.57,SCTP,0)),U,1)

 ;

TEAMNM(SCTM) ;return team name

 Q $P($G(^SCTM(404.51,SCTM,0)),U,1)

 ;

CLINIC(SCCL) ;return clinic name

 Q $P($G(^SC(+SCCL,0)),U,1)

 ;

YESNO() ;

 N DIR,X,Y

 S DIR(0)="Y",DIR("B")="YES"

 D ^DIR

 Q Y>0

 ;

YESNO2() ;

 N DIR,X,Y

 S DIR(0)="Y",DIR("B")="NO"

 S DIR("A")="Do you wish to continue with the assignment (Yes/No)?"

 D ^DIR

 Q Y>0

CONFIRM() ;confirmation call

 N DIR,X,Y

 S DIR("A")="Are you sure (Yes/No)"

 S DIR(0)="Y"

 D ^DIR

 Q +Y=1

 ;

SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE

 N DIR,X,Y

 W !,"Choose way to select NON PC POSITION Assignment: "

 S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"

 S DIR("B")=1

 D ^DIR

 Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT")

 ;

DATE(TYPE) ;return date type=A or D

 N DIR,X,Y

 S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: "

 S DIR(0)="DA^::EXP"

 S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")

 X ^DD("DD")

 S DIR("B")=Y

 D ^DIR

 Q Y

 ;

PRACSCR(SC40452) ;screen for for file 404.52

 N SCP,SCNODE,OK

 S SCP=$G(^SCTM(404.52,SC40452,0))

 S OK=0

 G:'SCP QTPP

 S SCNODE=$G(^SCTM(404.57,+SCP,0))

 S OK=$S($P(SCNODE,U,2)'=SCTM:0,$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)

QTPP Q OK

 ;

POSSCR(SCTP) ;screen for file 404.57

 N SCNODE

 S SCNODE=$G(^SCTM(404.57,SCTP,0))

 Q $S($P(SCNODE,U,2)'=SCTM:0,$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)

 Q

NEW() ;

 F I=0:0 S I=$O(SCD(I)) Q:'I  I (+SCD(I))=(+Y) Q

 Q 'I

SCMCQK2   ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002  12:10 PM

 +1       ;;5.3;Scheduling;**297,1015**;AUG 13, 1993;Build 21

 +2       ;

DSPL      ;

 +1        NEW LP,SCD,SCPOS

 +2        SET SCTOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")

 +3        SET SCOK=$$TPPT^SCAPMC(DFN,"","","","","","","SCPOS","SCBKERR")

 +4       ;

 +5       ;loop through positions only getting the ones associated with the team

 +6       ;and that are active.

 +7       ;

 +8        FOR LP=0:0

               SET LP=$ORDER(SCPOS(LP))

               IF 'LP

                   QUIT 

               Begin DoDot:1

 +9                IF $PIECE(SCPOS(LP),U,6)]""

                       KILL SCPOS(LP)

                       QUIT 

 +10               SET SCPOS("T",$PIECE(SCPOS(LP),U,3),+SCPOS(LP))=SCPOS(LP)

               End DoDot:1

 +11       SET CNT=0

           SET POS=0

 +12       FOR LP=0:0

               SET LP=$ORDER(SCD(LP))

               IF 'LP

                   QUIT 

               SET A=SCD(LP)

               IF '$PIECE(A,U,8)

                   Begin DoDot:1

 +13                   IF 'CNT

                           WRITE !!,"NON PC ASSIGNMENTS",!

 +14                   SET CNT=CNT+1

                       WRITE !,CNT,?4,"Non-PC Team: "_$PIECE(A,U,2),?48,"Phone: "_$PIECE($GET(^SCTM(404.51,+A,0)),U,2)

                       SET DATA(CNT)=+A

 +15                   FOR I=0:0

                           SET I=$ORDER(SCPOS("T",+A,I))

                           IF 'I

                               QUIT 

                           Begin DoDot:2

 +16                           IF $PIECE(DATA(CNT),U,2)

                                   SET CNT=CNT+1

 +17                           SET B=SCPOS("T",+A,I)

 +18                           SET DATA(CNT)=(+A)_U_(+B)

                               SET POS=1

 +19                           SET SCPR=$$GETPRTP^SCAPMCU2(+B,DT)

                               SET RES=$$NEWPERSN^SCMCGU(+SCPR,"SCPR")

 +20                           IF $X>76

                                   WRITE !,CNT,?4,"Non-PC Team: "_$PIECE(A,U,2),?48,"Phone: "_$PIECE($GET(^SCTM(404.51,+A,0)),U,2)

 +21                           WRITE !,?7,"Provider: "_$PIECE(SCPR,U,2),?45,"Position: "_$PIECE(B,U,2)_"       "

 +22                           WRITE !,?10,"Pager: "_$PIECE($GET(SCPR(+SCPR)),U,5),?48,"Phone: ",$PIECE($GET(SCPR(+SCPR)),U,2),?77," "

                           End DoDot:2

                   End DoDot:1

 +23       IF 'CNT

               WRITE !,"No active NON PC ASSIGNMENTS for this patient",!

 +24       QUIT 

NPC        NEW SCDT,SCER1,SCD,SCPOS

 +1        DO DSPL

 +2        SET DIR(0)="SO^0:NONE;1:TEAM ASSIGNMENT;"_$SELECT(CNT:"2:POSITION ASSIGNMENT;3:UNASSIGNMENT;",1:"")

 +3        SET DIR("B")=1

 +4        DO ^DIR

 +5        IF Y=0

               QUIT 

 +6        IF Y=U

               QUIT 

 +7        IF Y=1

               DO ASTM

               GOTO NPC

READ       IF CNT=1

               SET X=1

           IF CNT>1

               WRITE !,"Select 1-"_CNT_": "

               READ X:DTIME

               IF X=U

                   QUIT 

               SET X=+X

               IF X>CNT!X<1

                   GOTO READ

 +1        IF Y=3

               SET DATA=DATA(+X)

               SET SCTPSTAT=1

               SET SCTP=+$PIECE(DATA,U,2)

               SET SCTM=+DATA

               IF SCTP

                   DO UNTP

               IF 'SCTP

                   DO UNTM

               GOTO NPC

 +2        SET DATA=DATA(+X)

           SET SCTM=+DATA

           SET SCSELECT=$$SELPOS()

           IF '$LENGTH(SCSELECT)

               GOTO NPC

           DO ASTP

           GOTO NPC

 +3        QUIT 

UNTP      ;unassign patient from position

 +1        IF '$GET(SCTP)

               WRITE !,"No position defined"

               QUIT 

 +2        NEW OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 +3        SET OK=0

 +4        WRITE !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position   ["_$PIECE($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]"

 +5        SET SCDISCH=$$DATE("D")

 +6        IF SCDISCH<1

               GOTO QTUNTP

 +7        IF '$$CONFIRM()

               GOTO QTUNTP

 +8        SET OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)

 +9        IF OK'>0

               GOTO QTUNTP

 +10       SET SCCL=$PIECE($GET(^SCTM(404.57,+$GET(SCTP),0)),U,9)

QTUNTP     WRITE !,"Position Unassignment "_$SELECT(OK:"made.",1:"NOT made.")

 +1        QUIT 

 +2       ;

 +3       ;

UNTM      ;

 +1       ;assign patient from non pc team (and pc position if possible)

 +2        NEW OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3

 +3        SET OK=0

 +4        WRITE !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team"

 +5        IF 'SCTPSTAT

               WRITE !,?5,"AND from "_$$POSITION(SCTP)_" position  ["_$$WRITETP^SCMCDD1(SCTP)_"]"

 +6        SET SCDISCH=$$DATE("D")

 +7        IF SCDISCH<1

               GOTO QTUNTM

 +8        IF '$$CONFIRM()

               GOTO QTUNTM

 +9        IF 'SCTPSTAT

               Begin DoDot:1

 +10               WRITE !,"Unassigned."

 +11               SET OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)

 +12               IF OK2>0

                       Begin DoDot:2

 +13                       WRITE "made."

 +14                       SET SCCL=$PIECE(^SCTM(404.57,SCTP,0),U,9)

                       End DoDot:2

               End DoDot:1

               IF OK2'>0

                   GOTO QTUNTM

 +15       SET OK3=$$ALLPOS^SCMCQK1()

 +16       IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH)

               Begin DoDot:1

 +17               SET OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER)

               End DoDot:1

 +18      IF '$TEST

               Begin DoDot:1

 +19               WRITE !,"Future/Current Patient-Position Assignment exists"

               End DoDot:1

QTUNTM     WRITE !,"Team Unassignment "_$SELECT(OK:"made",1:"NOT made.")

 +1        QUIT 

 +2       ;

ASTM      ;assign patient to team

 +1        NEW DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 +2        SET OK=0

 +3        WRITE !!,"About to Assign "_$$NAME(DFN)_" to a non primary care team"

 +4        IF $$SC^SCMCQK1(DFN)

               WRITE !!,"********** This patient is 50 percent or greater service-connected ************"

 +5        SET DIC="^SCTM(404.51,"

 +6        SET DIC(0)="AEMQZ"

 +7        SET DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT) I $$NEW^SCMCQK2()"

 +8       ;  - select from active teams that can not be PC Teams

 +9        DO ^DIC

 +10       IF Y<1

               GOTO QTASTM

 +11       SET SCTM=+Y

 +12       SET SCASSDT=$$DATE("A")

 +13       IF SCASSDT<1

               GOTO QTASTM

 +14       SET SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM)

 +15       SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SCTM),"^",8)

 +16       IF SCTMCT'<SCTMMAX

               Begin DoDot:1

 +17               WRITE !,"This assignment will reach or exceeded the maximum set for this team."

 +18               WRITE !,"Currently assigned: "_SCTMCT

 +19               WRITE !,"Maximum set for team: "_SCTMMAX

               End DoDot:1

               IF '$$YESNO2()

                   GOTO QTASTM

 +20       IF SCTMCT<SCTMMAX

               IF '$$CONFIRM()

                   GOTO QTASTM

 +21       SET SCTM=+Y

 +22      ;setup fields

 +23      ;S SCTMFLDS(.08)=1 ;primary care assignment

 +24       SET SCTMFLDS(.11)=$GET(DUZ,.5)

 +25       DO NOW^%DTC

           SET SCTMFLDS(.12)=%

 +26       IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",SCASSDT,"SCTPTME")

               Begin DoDot:1

 +27               SET SCSELECT=$$SELPOS()

 +28      ;prompt for position prompt

                   IF $LENGTH(SCSELECT)

                       DO ASTP

 +29               SET OK=1

               End DoDot:1

QTASTM     WRITE !,"Team Assignment "_$SELECT(OK:"made",1:"NOT made.")

 +1        QUIT 

ASTP      ;assign patient to practitioner

 +1        NEW DIC,Y,OK,SCCL,X,SCTPFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS

 +2        SET OK=0

 +3        WRITE !!,"About to Assign "_$$NAME(DFN)_" to non PC Position Assignment"

 +4        IF $$SC^SCMCQK1(DFN)

               WRITE !!,"********** This patient is 50 percent or greater service-connected ************"

 +5       ;lookup to display only position and [practitioner]

 +6        IF SCSELECT="PRACT"

               Begin DoDot:1

 +7                SET DIC("W")="N SCP1 S SCP1=$G(^SCTM(404.52,Y,0)) W ""    ["",$P($G(^VA(200,+$P(SCP1,U,3),0)),U,1),""]"""

 +8                SET DIC("A")="POSITION's Current PRACTITIONER: "

 +9                SET DIC="^SCTM(404.52,"

 +10      ;Must be from team, must be active,must not have future inactivation

 +11               SET DIC("S")="I $$PRACSCR^SCMCQK2(Y)"

 +12               SET D="C"

               End DoDot:1

 +13      IF '$TEST

               Begin DoDot:1

 +14               SET DIC="^SCTM(404.57,"

 +15               SET D="B"

 +16               SET DIC("A")="POSITION's Name: "

 +17               SET DIC("S")="I $$POSSCR^SCMCQK2(Y)"

               End DoDot:1

 +18       SET DIC(0)="AEMQZ"

 +19       DO MIX^DIC1

 +20       IF Y<1

               GOTO QTASTP

 +21       IF SCSELECT="PRACT"

               Begin DoDot:1

 +22               SET SCTP=$PIECE(Y,U,2)

               End DoDot:1

 +23      IF '$TEST

               Begin DoDot:1

 +24               SET SCTP=$PIECE(Y,U,1)

               End DoDot:1

 +25       SET SCASSDT=$$DATE("A")

 +26       IF SCASSDT<1

               GOTO QTASTP

 +27       SET SCTMCT=$$PCPOSCNT^SCAPMCU1(SCTP)

           SET SCTMMAX=+$PIECE($GET(^SCTM(404.57,SCTP,0)),U,8)

 +28       IF SCTMCT'<SCTMMAX

               Begin DoDot:1

 +29               WRITE !,"This assignment will reach or exceeded the maximum set for this position."

 +30               WRITE !,"Currently assigned: "_SCTMCT

 +31               WRITE !,"Maximum set for position: "_SCTMMAX

               End DoDot:1

               IF '$$YESNO2

                   GOTO QTASTP

 +32       IF '$$CONFIRM()

               GOTO QTASTP

 +33      ;setup fields

 +34       SET SCTPFLDS(.03)=SCASSDT

 +35      ;S SCTPFLDS(.05)=1 ;pc pract role

 +36       SET SCTPFLDS(.06)=$GET(DUZ,.5)

 +37       DO NOW^%DTC

           SET SCTPFLDS(.07)=%

 +38       IF $$ACPTTP^SCAPMC21(DFN,SCTP,"SCTPFLDS",SCASSDT,"SCTPTME",0)

               Begin DoDot:1

 +39               SET OK=1

 +40               SET SCCL=$PIECE(^SCTM(404.57,SCTP,0),U,9)

               End DoDot:1

QTASTP     WRITE !,"Position Assignment "_$SELECT(OK:"made",1:"NOT made.")

 +1        QUIT 

NAME(DFN) ;return patient name

 +1        QUIT $PIECE($GET(^DPT(DFN,0)),U,1)

 +2       ;

POSITION(SCTP) ;return position name

 +1        QUIT $PIECE($GET(^SCTM(404.57,SCTP,0)),U,1)

 +2       ;

TEAMNM(SCTM) ;return team name

 +1        QUIT $PIECE($GET(^SCTM(404.51,SCTM,0)),U,1)

 +2       ;

CLINIC(SCCL) ;return clinic name

 +1        QUIT $PIECE($GET(^SC(+SCCL,0)),U,1)

 +2       ;

YESNO()   ;

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="Y"

           SET DIR("B")="YES"

 +3        DO ^DIR

 +4        QUIT Y>0

 +5       ;

YESNO2()  ;

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="Y"

           SET DIR("B")="NO"

 +3        SET DIR("A")="Do you wish to continue with the assignment (Yes/No)?"

 +4        DO ^DIR

 +5        QUIT Y>0

CONFIRM() ;confirmation call

 +1        NEW DIR,X,Y

 +2        SET DIR("A")="Are you sure (Yes/No)"

 +3        SET DIR(0)="Y"

 +4        DO ^DIR

 +5        QUIT +Y=1

 +6       ;

SELPOS()  ;return way to select position: 1=PRACT,2=POSIT,3=NONE

 +1        NEW DIR,X,Y

 +2        WRITE !,"Choose way to select NON PC POSITION Assignment: "

 +3        SET DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT"

 +4        SET DIR("B")=1

 +5        DO ^DIR

 +6        QUIT $SELECT(Y'>0:"",+Y=1:"PRACT",1:"POSIT")

 +7       ;

DATE(TYPE) ;return date type=A or D

 +1        NEW DIR,X,Y

 +2        SET DIR("A")=$SELECT(TYPE="A":"Assignment",1:"Unassignment")_" date: "

 +3        SET DIR(0)="DA^::EXP"

 +4        SET Y=$SELECT($DATA(SCDISCH):SCDISCH,$DATA(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1")

 +5        XECUTE ^DD("DD")

 +6        SET DIR("B")=Y

 +7        DO ^DIR

 +8        QUIT Y

 +9       ;

PRACSCR(SC40452) ;screen for for file 404.52

 +1        NEW SCP,SCNODE,OK

 +2        SET SCP=$GET(^SCTM(404.52,SC40452,0))

 +3        SET OK=0

 +4        IF 'SCP

               GOTO QTPP

 +5        SET SCNODE=$GET(^SCTM(404.57,+SCP,0))

 +6        SET OK=$SELECT($PIECE(SCNODE,U,2)'=SCTM:0,$PIECE(SCNODE,U,4):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$PIECE(SCP,U,2)):0,($ORDER(^SCTM(404.52,"AIDT",+SCP,0,-$PIECE(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0)

QTPP       QUIT OK

 +1       ;

POSSCR(SCTP) ;screen for file 404.57

 +1        NEW SCNODE

 +2        SET SCNODE=$GET(^SCTM(404.57,SCTP,0))

 +3        QUIT $SELECT($PIECE(SCNODE,U,2)'=SCTM:0,$PIECE(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0)

 +4        QUIT 

NEW()     ;

 +1        FOR I=0:0

               SET I=$ORDER(SCD(I))

               IF 'I

                   QUIT 

               IF (+SCD(I))=(+Y)

                   QUIT 

 +2        QUIT 'I