50 lines
1.7 KiB
Mathematica
50 lines
1.7 KiB
Mathematica
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
|