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

SDWLE7.m

Go to the documentation of this file. 
  1. SDWLE7() ;;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - MOVE EWL ENTRY  ; Compiled August 14, 2007 11:18:43
  1.  ;;5.3;scheduling;**446,1015**;AUG 13 1993;Build 21
  1.  ;
  1.  ;  ******************************************************************
  1.  ;  CHANGE LOG
  1.  ;       
  1.  ;   DATE         PATCH    DESCRIPTION
  1.  ;   ----         -----    -----------
  1.  ;   
  1. EN() ;
  1.  N SDWLERR,SDWLCM,SDWLIN1,SDWLOPT,SDWLSC1,SDWLSC1X
  1.  S (SDWLERR,SDWLOPT)=1,SDWLCM=""
  1.  F  D @("P"_SDWLOPT) Q:'SDWLOPT
  1.  Q SDWLERR
  1.  ;
  1. P1 ; Institution
  1.  S DIR(0)="PAO^DIC(4,:EMNZ"
  1.  S DIR("A")="Select Institution: "
  1.  S DIR("B")=$$GET1^DIQ(4,SDWLIN,.01)
  1.  S DIR("S")="I $E(+Y,1,3)=$E(SDWLIN,1,3)"
  1.  D ^DIR
  1.  I Y<1 S SDWLOPT=0 Q
  1.  S SDWLIN1=+Y,SDWLOPT=2
  1.  Q
  1. P2 ; Clinic
  1.  N DIR,Y,SDWLI,SDWLSTOP,SDWLSTP1,TMP
  1.  S DIR(0)="PAO^SDWL(409.32,:EMNZ",DIR("A")="Select Clinic: "
  1.  S DIR("S")="I +Y'=SDWLSC,$P(^SC($$GET1^DIQ(409.32,+Y,.01,""I""),0),U,4)=SDWLIN1"
  1.  D ^DIR
  1.  I Y="^" S SDWLOPT=0 Q
  1.  I Y<1 S SDWLOPT=1 Q
  1.  S SDWLSCL=+Y,SDWLSC1X=$$GET1^DIQ(409.32,SDWLSCL,.01)
  1.  S SDWLSTOP=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSC,.01,"I"),8,"I")
  1.  S SDWLSTP1=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSCL,.01,"I"),8,"I")
  1.  I SDWLSTOP=SDWLSTP1 S SDWLOPT=3 Q
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S TMP(0)=1,TMP(1,0)=$$GET1^DIQ(409.32,SDWLSC,.01)_" and "_SDWLSC1X_" have different stop codes."
  1.  D COL80^SDWLIFT(.TMP) F SDWLI=1:1:TMP(0) S DIR("A",SDWLI)=TMP(SDWLI,0)
  1.  S DIR("A")="Do you want to proceed?"
  1.  S DIR("B")="NO" D ^DIR
  1.  S SDWLOPT=Y*3  ; +Y=0: SDWLOPT=0; Y=1: SDWLOPT=3
  1.  Q
  1.  ;
  1. P3 ; Comment
  1.  D P4^SDWLE6
  1.  Q
  1.  ;
  1. P4 ; Display data and confirm.
  1.  N DIR,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLEEST,Y
  1.  D GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;27","I","SDWLTMP")
  1.  S SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
  1.  S SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
  1.  S SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
  1.  S SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
  1.  S SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
  1.  S DIR(0)="Y"
  1.  S DIR("A",1)="The following EWL entry will be created"
  1.  S Y=SDWLORDT D DD^%DT
  1.  S DIR("A",2)="Originating Date: "_Y
  1.  S DIR("A",3)="Institution: "_$$GET1^DIQ(4,SDWLIN1,.01)
  1.  S DIR("A",4)="Wait List Type: SPECIFIC CLINIC"
  1.  S DIR("A",5)="Clinic: "_SDWLSC1X
  1.  S Y=SDWLDDT D DD^%DT
  1.  S DIR("A",6)="Desired Date of Appointment: "_Y
  1.  S DIR("A",7)="Comments: "_SDWLCM
  1.  S DIR("A")="Continue?"
  1.  S DIR("B")="YES"
  1.  D ^DIR
  1.  S SDWLOPT=0
  1.  Q:'Y
  1.  I '$$UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA) S SDWLOPT=3
  1.  Q
  1. UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA) ; Create new EWL entry
  1.  N DA,DIC,DIE,DR,X
  1.  S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
  1.  L +^SDWL(409.3,DA):1  ; This file has just been created. Is it neurotic to code for the possibility of a lock from elsewhere?
  1.  I '$T W !,"Unable to acquire a lock on the Wait List file" Q 0
  1.  S DIE=DIC
  1.  S DR="1////^S X=SDWLORDT"
  1.  S DR=DR_";2////^S X=SDWLIN"
  1.  S DR=DR_";4////^S X=4"
  1.  S DR=DR_";8////^S X=SDWLSCL"
  1.  S DR=DR_";9////^S X=DUZ"
  1.  S DR=DR_";14////^S X=SDWLSCPG"
  1.  S DR=DR_";15////^S X=SDWLSCPR"
  1.  S DR=DR_";22////^S X=SDWLDDT"
  1.  S DR=DR_";23////^S X=""O"""
  1.  S DR=DR_";25////^S X=SDWLCM"
  1.  S DR=DR_";27////^S X=SDWLEEST"
  1.  S DR=DR_";37////^S X=SDWLDA"
  1.  D ^DIE
  1.  L -^SDWL(409.3,DA)
  1.  S SDWLERR=0
  1.  Q 1