SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
;;5.3;Scheduling;**41,130**;AUG 13, 1993
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCPM1 1830 printed Dec 13, 2024@02:41:08 Page 2
SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
+1 ;;5.3;Scheduling;**41,130**;AUG 13, 1993
+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
