source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCPM1.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.7 KB
RevLine 
[613]1SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
2 ;;5.3;Scheduling;**41,130**;AUG 13, 1993
3 ;
4PCMMDIS ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is
5 ; called by the patient movement event driver
6 Q:$D(ZTQUEUED) ;interactive - quit if queued
7 ;check if patient has a current PC team if no prompt to enroll
8 Q:$P($G(DGPMA),U,2)'=3 ;must be a discharge
9 Q:'$G(DFN) ;should exist
10 Q:'$P($G(^SD(404.91,1,"PCMM")),U,2) ; check turn off flag
11 N DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT
12 D:'$G(DGQUIET) EN^DDIOL("Checking Primary Care Status...")
13 ;display PC info, check if patient has a current PC team
14 D PCMM^SCRPU4(DFN,DT)
15 G:$$NMPCTM^SCAPMCU2(DFN,DT,1) END
16 ;if not, check if patient has a PC team in the future
17 S SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)
18 IF 'SCOK D G END
19 .D:'$G(DGQUIET) EN^DDIOL($P(SCOK,U,2))
20 ;if not either, ask if they want to assign a patient to a PC team
21 S DIR(0)="Y"
22 S DIR("A")="Do you wish to assign patient to Primary Care"
23 S DIR("B")="NO"
24 D ^DIR
25 G:'Y END
26 S DIR(0)="Y"
27 S DIR("A")="Do you wish to assign patient to a Primary Care Team"
28 S DIR("B")="NO"
29 D ^DIR
30 IF 'Y D G END
31 .S SCOUTFLD(.04)=1
32 .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
33 .D:SCX&'($G(DGQUIET)) EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")
34 S DIC="^SCTM(404.51,"
35 S DIC(0)="AEMQZ"
36 S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
37 ; - select from active teams that can be PC Teams
38 D ^DIC
39 G:Y<1 END
40 S SCTM=+Y
41 ;setup fields
42 S SCTMFLDS(.02)=DT
43 S SCTMFLDS(.08)=1 ;primary care assignment
44 S SCTMFLDS(.11)=$G(DUZ,.5)
45 D NOW^%DTC S SCTMFLDS(.12)=%
46 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",DT,"SCTPTME") D
47 .D:'$G(DGQUIET) EN^DDIOL("...PC Team Assignment Made")
48END ;
49 Q
Note: See TracBrowser for help on using the repository browser.