Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCPM1

SCMCPM1.m

Go to the documentation of this file.
  1. SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
  1. ;;5.3;Scheduling;**41,130**;AUG 13, 1993
  1. ;
  1. PCMMDIS ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is
  1. ; called by the patient movement event driver
  1. Q:$D(ZTQUEUED) ;interactive - quit if queued
  1. ;check if patient has a current PC team if no prompt to enroll
  1. Q:$P($G(DGPMA),U,2)'=3 ;must be a discharge
  1. Q:'$G(DFN) ;should exist
  1. Q:'$P($G(^SD(404.91,1,"PCMM")),U,2) ; check turn off flag
  1. N DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT
  1. D:'$G(DGQUIET) EN^DDIOL("Checking Primary Care Status...")
  1. ;display PC info, check if patient has a current PC team
  1. D PCMM^SCRPU4(DFN,DT)
  1. G:$$NMPCTM^SCAPMCU2(DFN,DT,1) END
  1. ;if not, check if patient has a PC team in the future
  1. S SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)
  1. IF 'SCOK D G END
  1. .D:'$G(DGQUIET) EN^DDIOL($P(SCOK,U,2))
  1. ;if not either, ask if they want to assign a patient to a PC team
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you wish to assign patient to Primary Care"
  1. S DIR("B")="NO"
  1. D ^DIR
  1. G:'Y END
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you wish to assign patient to a Primary Care Team"
  1. S DIR("B")="NO"
  1. D ^DIR
  1. IF 'Y D G END
  1. .S SCOUTFLD(.04)=1
  1. .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
  1. .D:SCX&'($G(DGQUIET)) EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")
  1. S DIC="^SCTM(404.51,"
  1. S DIC(0)="AEMQZ"
  1. S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
  1. ; - select from active teams that can be PC Teams
  1. D ^DIC
  1. G:Y<1 END
  1. S SCTM=+Y
  1. ;setup fields
  1. S SCTMFLDS(.02)=DT
  1. S SCTMFLDS(.08)=1 ;primary care assignment
  1. S SCTMFLDS(.11)=$G(DUZ,.5)
  1. D NOW^%DTC S SCTMFLDS(.12)=%
  1. IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",DT,"SCTPTME") D
  1. .D:'$G(DGQUIET) EN^DDIOL("...PC Team Assignment Made")
  1. END ;
  1. Q