SCMCQK.m

SCMCQK ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 1 Jul 1998

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

 ;

EN ; - main call

 W !,"Primary Care Team/PC Assignment/Unassignment",!

 W !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)"

 W !,?6,"must be used to:"

 W !,?10,"1) Setup active primary care and non-primary care team(s)"

 W !,?10,"2) Setup active PC and non-primary care Practitioner position(s)"

 W !,?10,"3) Setup any necessary preceptor/preceptee relationships"

 W !,?10,"4) Assign practitioner to position(s)"

 W !!?6,"A patient can only have one PC team and one"

 W !?6,"PC Position assignment on a given day.  The patient must be"

 W !?6,"assigned to a position's team to be assigned to the position."

 W !!?6,"Note: You must use the PCMM GUI if the patient was:"

 W !?10,"o unassigned from PC assignment today or in the future"

 W !?10,"o assigned to a future PC assignment."

 N DFN

 F  S DFN=$$PATIENT() Q:DFN<0  D PAT

 Q

 ;

PAT ;process patient

 Q:'$G(DFN)

 N SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP

 W !,"Checking PC Team and Position Status...",!

 ;display PC info, check if patient has a current PC team

 D PCMM^SCRPU4(DFN,DT)

 D DSPL^SCMCQK2

 N DATA

 S DATA=$$IU^SCMCTSK1(DFN)

 I $E(DATA)=1 I $D(^XUSEC("SC PCMM SETUP",+$G(DUZ))) D

 .W !,"This patient was inactivated from "_$P(DATA,"~",2)_" TEAM"

 .W !,$P(DATA,"~",4)_" Position"

 .W !,"Do you wish to reactivate" S %=2 D YN^DICN

 .I %=1 D FILEIN^SCMCTSK3(.DATA,+$P(DATA,"~",6))

 W !,"Do you want to make a primary care assignment/unassignment" S %=1 D YN^DICN Q:%<0

 I %=2 G NPC^SCMCQK2

 ;below functions return status^message^pointer

 S SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT)  ;ok to assign new PC team?

 S SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1)  ;ok to assign new PC prac?

 ;what is current/future PC assignment status?

 S SCSTAT=$S((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR")  ;error if PC pract w/o PC team assignment

 W:SCSTAT="NONE" !,"No current PC Team/PC Practitioner Assignments"

 IF $S(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0) W !,$P(SCTMSTAT,U,2) S SCSTAT="FUTURE"

 IF $S(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0) W !,$P(SCTPSTAT,U,2) S SCSTAT="FUTURE"

 S SCTM=$P(SCTMSTAT,U,3)

 S SCTP=$P(SCTPSTAT,U,3)

 D @SCSTAT

 D BREAK

 Q

 ;

BREAK ;

 N DIR,X,Y

 S DIR(0)="EA",DIR("A",1)="",DIR("A")="Press enter to continue."

 D ^DIR

 Q

 ;

NONE ;

 N SCASSDT

 D ASTM^SCMCQK1

 Q

TEAM ;

 N DIR,X,Y,SCDISCH,SCASSDT,SCSELECT

 S DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT"

 D ^DIR

 IF $P(Y,U,1)=1!($P(Y,U,1)=2) D

 .S SCSELECT=$S($P(Y,U,1)=1:"PRACT",1:"POSIT")

 .D ASTP^SCMCQK1

 ELSE  D:$P(Y,U,1)=3 UNTM^SCMCQK1

 Q

 ;

BOTH ;

 N DIR,X,Y,SCDISCH

 S DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT"

 D ^DIR

 IF $P(Y,U,1)=1 D

 .D UNTP^SCMCQK1

 ELSE  D:$P(Y,U,1)=2 UNTM^SCMCQK1

 Q

 ;

FUTURE ;

 W !,"This patient has future assignments for Primary Care"

 W !,"Team and/or Practitioner"

 W !!!,"You must use PCMM's Graphical User Interface to change"

 Q

 ;

ERROR ;

 W !,"This patient has NO active Primary Care Team, but does have"

 W !,"an active PC Position Assignment"

 W !!!,"You must use PCMM's Graphical User Interface to correct"

 Q

 ;

PATIENT() ;Return Patient DFN or -1

 ;

 N DIC,X,Y

 W !!!

 S DIC=2

 S DIC(0)="AEMQZ"

 D ^DIC

 Q $S($D(DTOUT):-1,$D(DUOUT):-1,(Y<0):-1,1:+Y)

SCMCQK    ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 1 Jul 1998

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

 +2       ;

EN        ; - main call

 +1        WRITE !,"Primary Care Team/PC Assignment/Unassignment",!

 +2        WRITE !,?6,"Prior to using this option, PCMM's Graphical User Interface (GUI)"

 +3        WRITE !,?6,"must be used to:"

 +4        WRITE !,?10,"1) Setup active primary care and non-primary care team(s)"

 +5        WRITE !,?10,"2) Setup active PC and non-primary care Practitioner position(s)"

 +6        WRITE !,?10,"3) Setup any necessary preceptor/preceptee relationships"

 +7        WRITE !,?10,"4) Assign practitioner to position(s)"

 +8        WRITE !!?6,"A patient can only have one PC team and one"

 +9        WRITE !?6,"PC Position assignment on a given day.  The patient must be"

 +10       WRITE !?6,"assigned to a position's team to be assigned to the position."

 +11       WRITE !!?6,"Note: You must use the PCMM GUI if the patient was:"

 +12       WRITE !?10,"o unassigned from PC assignment today or in the future"

 +13       WRITE !?10,"o assigned to a future PC assignment."

 +14       NEW DFN

 +15       FOR 

               SET DFN=$$PATIENT()

               IF DFN<0

                   QUIT 

               DO PAT

 +16       QUIT 

 +17      ;

PAT       ;process patient

 +1        IF '$GET(DFN)

               QUIT 

 +2        NEW SCTPSTAT,SCTMSTAT,SCSTAT,SCTM,SCTP

 +3        WRITE !,"Checking PC Team and Position Status...",!

 +4       ;display PC info, check if patient has a current PC team

 +5        DO PCMM^SCRPU4(DFN,DT)

 +6        DO DSPL^SCMCQK2

 +7        NEW DATA

 +8        SET DATA=$$IU^SCMCTSK1(DFN)

 +9        IF $EXTRACT(DATA)=1

               IF $DATA(^XUSEC("SC PCMM SETUP",+$GET(DUZ)))

                   Begin DoDot:1

 +10                   WRITE !,"This patient was inactivated from "_$PIECE(DATA,"~",2)_" TEAM"

 +11                   WRITE !,$PIECE(DATA,"~",4)_" Position"

 +12                   WRITE !,"Do you wish to reactivate"

                       SET %=2

                       DO YN^DICN

 +13                   IF %=1

                           DO FILEIN^SCMCTSK3(.DATA,+$PIECE(DATA,"~",6))

                   End DoDot:1

 +14       WRITE !,"Do you want to make a primary care assignment/unassignment"

           SET %=1

           DO YN^DICN

           IF %<0

               QUIT 

 +15       IF %=2

               GOTO NPC^SCMCQK2

 +16      ;below functions return status^message^pointer

 +17      ;ok to assign new PC team?

           SET SCTMSTAT=$$YSPTTMPC^SCMCTMU2(DFN,DT)

 +18      ;ok to assign new PC prac?

           SET SCTPSTAT=$$YSPTTPPC^SCMCTPU2(DFN,DT,1)

 +19      ;what is current/future PC assignment status?

 +20      ;error if PC pract w/o PC team assignment

           SET SCSTAT=$SELECT((SCTMSTAT&SCTPSTAT):"NONE",('SCTMSTAT&SCTPSTAT):"TEAM",('SCTMSTAT&'SCTPSTAT):"BOTH",1:"ERROR")

 +21       IF SCSTAT="NONE"

               WRITE !,"No current PC Team/PC Practitioner Assignments"

 +22       IF $SELECT(SCTMSTAT:0,(SCTMSTAT["future"):1,1:0)

               WRITE !,$PIECE(SCTMSTAT,U,2)

               SET SCSTAT="FUTURE"

 +23       IF $SELECT(SCTPSTAT:0,(SCTPSTAT["future"):1,1:0)

               WRITE !,$PIECE(SCTPSTAT,U,2)

               SET SCSTAT="FUTURE"

 +24       SET SCTM=$PIECE(SCTMSTAT,U,3)

 +25       SET SCTP=$PIECE(SCTPSTAT,U,3)

 +26       DO @SCSTAT

 +27       DO BREAK

 +28       QUIT 

 +29      ;

BREAK     ;

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="EA"

           SET DIR("A",1)=""

           SET DIR("A")="Press enter to continue."

 +3        DO ^DIR

 +4        QUIT 

 +5       ;

NONE      ;

 +1        NEW SCASSDT

 +2        DO ASTM^SCMCQK1

 +3        QUIT 

TEAM      ;

 +1        NEW DIR,X,Y,SCDISCH,SCASSDT,SCSELECT

 +2        SET DIR(0)="SO^1:POSITION ASSIGNMENT - BY PRACTITIONER NAME;2:POSITION ASSIGNMENT - BY POSITION NAME;3:TEAM UNASSIGNMENT"

 +3        DO ^DIR

 +4        IF $PIECE(Y,U,1)=1!($PIECE(Y,U,1)=2)

               Begin DoDot:1

 +5                SET SCSELECT=$SELECT($PIECE(Y,U,1)=1:"PRACT",1:"POSIT")

 +6                DO ASTP^SCMCQK1

               End DoDot:1

 +7       IF '$TEST

               IF $PIECE(Y,U,1)=3

                   DO UNTM^SCMCQK1

 +8        QUIT 

 +9       ;

BOTH      ;

 +1        NEW DIR,X,Y,SCDISCH

 +2        SET DIR(0)="SO^1:PC ASSIGNMENT UNASSIGNMENT;2:TEAM UNASSIGNMENT"

 +3        DO ^DIR

 +4        IF $PIECE(Y,U,1)=1

               Begin DoDot:1

 +5                DO UNTP^SCMCQK1

               End DoDot:1

 +6       IF '$TEST

               IF $PIECE(Y,U,1)=2

                   DO UNTM^SCMCQK1

 +7        QUIT 

 +8       ;

FUTURE    ;

 +1        WRITE !,"This patient has future assignments for Primary Care"

 +2        WRITE !,"Team and/or Practitioner"

 +3        WRITE !!!,"You must use PCMM's Graphical User Interface to change"

 +4        QUIT 

 +5       ;

ERROR     ;

 +1        WRITE !,"This patient has NO active Primary Care Team, but does have"

 +2        WRITE !,"an active PC Position Assignment"

 +3        WRITE !!!,"You must use PCMM's Graphical User Interface to correct"

 +4        QUIT 

 +5       ;

PATIENT() ;Return Patient DFN or -1

 +1       ;

 +2        NEW DIC,X,Y

 +3        WRITE !!!

 +4        SET DIC=2

 +5        SET DIC(0)="AEMQZ"

 +6        DO ^DIC

 +7        QUIT $SELECT($DATA(DTOUT):-1,$DATA(DUOUT):-1,(Y<0):-1,1:+Y)