SCMCPM1.m

SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996

 ;;5.3;Scheduling;**41,130,1015**;AUG 13, 1993;Build 21

 ;

PCMMDIS ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is 

 ;   called by the patient movement event driver

 Q:$D(ZTQUEUED)  ;interactive - quit if queued

 ;check if patient has a current PC team if no prompt to enroll

 Q:$P($G(DGPMA),U,2)'=3  ;must be a discharge

 Q:'$G(DFN)  ;should exist

 Q:'$P($G(^SD(404.91,1,"PCMM")),U,2)  ; check turn off flag

 N DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT

 D:'$G(DGQUIET) EN^DDIOL("Checking Primary Care Status...")

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

 D PCMM^SCRPU4(DFN,DT)

 G:$$NMPCTM^SCAPMCU2(DFN,DT,1) END

 ;if not, check if patient has a PC team in the future

 S SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)

 IF 'SCOK D  G END

 .D:'$G(DGQUIET) EN^DDIOL($P(SCOK,U,2))

 ;if not either, ask if they want to assign a patient to a PC team

 S DIR(0)="Y"

 S DIR("A")="Do you wish to assign patient to Primary Care"

 S DIR("B")="NO"

 D ^DIR

 G:'Y END

 S DIR(0)="Y"

 S DIR("A")="Do you wish to assign patient to a Primary Care Team"

 S DIR("B")="NO"

 D ^DIR

 IF 'Y D  G END

 .S SCOUTFLD(.04)=1

 .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")

 .D:SCX&'($G(DGQUIET)) EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")

 S DIC="^SCTM(404.51,"

 S DIC(0)="AEMQZ"

 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"

 ;  - select from active teams that can be PC Teams

 D ^DIC

 G:Y<1 END

 S SCTM=+Y

 ;setup fields

 S SCTMFLDS(.02)=DT

 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",DT,"SCTPTME") D

 .D:'$G(DGQUIET) EN^DDIOL("...PC Team Assignment Made")

END ;

 Q

SCMCPM1   ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996

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

 +2       ;

PCMMDIS   ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is 

 +1       ;   called by the patient movement event driver

 +2       ;interactive - quit if queued

           IF $DATA(ZTQUEUED)

               QUIT 

 +3       ;check if patient has a current PC team if no prompt to enroll

 +4       ;must be a discharge

           IF $PIECE($GET(DGPMA),U,2)'=3

               QUIT 

 +5       ;should exist

           IF '$GET(DFN)

               QUIT 

 +6       ; check turn off flag

           IF '$PIECE($GET(^SD(404.91,1,"PCMM")),U,2)

               QUIT 

 +7        NEW DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT

 +8        IF '$GET(DGQUIET)

               DO EN^DDIOL("Checking Primary Care Status...")

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

 +10       DO PCMM^SCRPU4(DFN,DT)

 +11       IF $$NMPCTM^SCAPMCU2(DFN,DT,1)

               GOTO END

 +12      ;if not, check if patient has a PC team in the future

 +13       SET SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)

 +14       IF 'SCOK

               Begin DoDot:1

 +15               IF '$GET(DGQUIET)

                       DO EN^DDIOL($PIECE(SCOK,U,2))

               End DoDot:1

               GOTO END

 +16      ;if not either, ask if they want to assign a patient to a PC team

 +17       SET DIR(0)="Y"

 +18       SET DIR("A")="Do you wish to assign patient to Primary Care"

 +19       SET DIR("B")="NO"

 +20       DO ^DIR

 +21       IF 'Y

               GOTO END

 +22       SET DIR(0)="Y"

 +23       SET DIR("A")="Do you wish to assign patient to a Primary Care Team"

 +24       SET DIR("B")="NO"

 +25       DO ^DIR

 +26       IF 'Y

               Begin DoDot:1

 +27               SET SCOUTFLD(.04)=1

 +28               SET SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")

 +29               IF SCX&'($GET(DGQUIET))

                       DO EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")

               End DoDot:1

               GOTO END

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

 +31       SET DIC(0)="AEMQZ"

 +32       SET DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"

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

 +34       DO ^DIC

 +35       IF Y<1

               GOTO END

 +36       SET SCTM=+Y

 +37      ;setup fields

 +38       SET SCTMFLDS(.02)=DT

 +39      ;primary care assignment

           SET SCTMFLDS(.08)=1

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

 +41       DO NOW^%DTC

           SET SCTMFLDS(.12)=%

 +42       IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",DT,"SCTPTME")

               Begin DoDot:1

 +43               IF '$GET(DGQUIET)

                       DO EN^DDIOL("...PC Team Assignment Made")

               End DoDot:1

END       ;

 +1        QUIT