SDWLE7 ;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - MOVE EWL ENTRY ;1/11/16 10:31am
;;5.3;scheduling;**446,645**;AUG 13 1993;Build 7
;
; ******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;
EN() ;
N SDWLERR,SDWLCM,SDWLIN1,SDWLOPT,SDWLSC1,SDWLSC1X
S (SDWLERR,SDWLOPT)=1,SDWLCM=""
F D @("P"_SDWLOPT) Q:'SDWLOPT
Q SDWLERR
;
P1 ; Institution
S DIR(0)="PAO^DIC(4,:EMNZ"
S DIR("A")="Select Institution: "
S DIR("B")=$$GET1^DIQ(4,SDWLIN,.01)
S DIR("S")="I $E(+Y,1,3)=$E(SDWLIN,1,3)"
D ^DIR
I Y<1 S SDWLOPT=0 Q
S SDWLIN1=+Y,SDWLOPT=2
Q
P2 ; Clinic
N DIR,Y,SDWLI,SDWLSTOP,SDWLSTP1,TMP
S DIR(0)="PAO^SDWL(409.32,:EMNZ",DIR("A")="Select Clinic: "
S DIR("S")="I +Y'=SDWLSC,$P(^SC($$GET1^DIQ(409.32,+Y,.01,""I""),0),U,4)=SDWLIN1"
D ^DIR
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=1 Q
S SDWLSCL=+Y,SDWLSC1X=$$GET1^DIQ(409.32,SDWLSCL,.01)
S SDWLSTOP=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSC,.01,"I"),8,"I")
S SDWLSTP1=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSCL,.01,"I"),8,"I")
I SDWLSTOP=SDWLSTP1 S SDWLOPT=3 Q
K DIR
S DIR(0)="Y"
S TMP(0)=1,TMP(1,0)=$$GET1^DIQ(409.32,SDWLSC,.01)_" and "_SDWLSC1X_" have different stop codes."
D COL80^SDWLIFT(.TMP) F SDWLI=1:1:TMP(0) S DIR("A",SDWLI)=TMP(SDWLI,0)
S DIR("A")="Do you want to proceed?"
S DIR("B")="NO" D ^DIR
S SDWLOPT=Y*3 ; +Y=0: SDWLOPT=0; Y=1: SDWLOPT=3
Q
;
P3 ; Comment
D P4^SDWLE6
Q
;
P4 ; Display data and confirm.
N DIR,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLEEST,Y
D GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;27","I","SDWLTMP")
S SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
S SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
S SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
S SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
S SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
S DIR(0)="Y"
S DIR("A",1)="The following EWL entry will be created"
S Y=SDWLORDT D DD^%DT
S DIR("A",2)="Originating Date: "_Y
S DIR("A",3)="Institution: "_$$GET1^DIQ(4,SDWLIN1,.01)
S DIR("A",4)="Wait List Type: SPECIFIC CLINIC"
S DIR("A",5)="Clinic: "_SDWLSC1X
S Y=SDWLDDT D DD^%DT
; SD*5.3*645 - replaced Desired Date with CID/Preferred date
;S DIR("A",6)="Desired Date of Appointment: "_Y
S DIR("A",6)="CID/Preferred Date of Appointment: "_Y
S DIR("A",7)="Comments: "_SDWLCM
S DIR("A")="Continue?"
S DIR("B")="YES"
D ^DIR
S SDWLOPT=0
Q:'Y
I '$$UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA) S SDWLOPT=3
Q
UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA) ; Create new EWL entry
N DA,DIC,DIE,DR,X
S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
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?
I '$T W !,"Unable to acquire a lock on the Wait List file" Q 0
S DIE=DIC
S DR="1////^S X=SDWLORDT"
S DR=DR_";2////^S X=SDWLIN"
S DR=DR_";4////^S X=4"
S DR=DR_";8////^S X=SDWLSCL"
S DR=DR_";9////^S X=DUZ"
S DR=DR_";14////^S X=SDWLSCPG"
S DR=DR_";15////^S X=SDWLSCPR"
S DR=DR_";22////^S X=SDWLDDT"
S DR=DR_";23////^S X=""O"""
S DR=DR_";25////^S X=SDWLCM"
S DR=DR_";27////^S X=SDWLEEST"
S DR=DR_";37////^S X=SDWLDA"
D ^DIE
L -^SDWL(409.3,DA)
S SDWLERR=0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLE7 3407 printed Apr 09, 2024@21:49:40 Page 2
SDWLE7 ;IOFO BAY PINES/OG - WAITING LIST-ENTER/EDIT - MOVE EWL ENTRY ;1/11/16 10:31am
+1 ;;5.3;scheduling;**446,645**;AUG 13 1993;Build 7
+2 ;
+3 ; ******************************************************************
+4 ; CHANGE LOG
+5 ;
+6 ; DATE PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ;
EN() ;
+1 NEW SDWLERR,SDWLCM,SDWLIN1,SDWLOPT,SDWLSC1,SDWLSC1X
+2 SET (SDWLERR,SDWLOPT)=1
SET SDWLCM=""
+3 FOR
DO @("P"_SDWLOPT)
if 'SDWLOPT
QUIT
+4 QUIT SDWLERR
+5 ;
P1 ; Institution
+1 SET DIR(0)="PAO^DIC(4,:EMNZ"
+2 SET DIR("A")="Select Institution: "
+3 SET DIR("B")=$$GET1^DIQ(4,SDWLIN,.01)
+4 SET DIR("S")="I $E(+Y,1,3)=$E(SDWLIN,1,3)"
+5 DO ^DIR
+6 IF Y<1
SET SDWLOPT=0
QUIT
+7 SET SDWLIN1=+Y
SET SDWLOPT=2
+8 QUIT
P2 ; Clinic
+1 NEW DIR,Y,SDWLI,SDWLSTOP,SDWLSTP1,TMP
+2 SET DIR(0)="PAO^SDWL(409.32,:EMNZ"
SET DIR("A")="Select Clinic: "
+3 SET DIR("S")="I +Y'=SDWLSC,$P(^SC($$GET1^DIQ(409.32,+Y,.01,""I""),0),U,4)=SDWLIN1"
+4 DO ^DIR
+5 IF Y="^"
SET SDWLOPT=0
QUIT
+6 IF Y<1
SET SDWLOPT=1
QUIT
+7 SET SDWLSCL=+Y
SET SDWLSC1X=$$GET1^DIQ(409.32,SDWLSCL,.01)
+8 SET SDWLSTOP=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSC,.01,"I"),8,"I")
+9 SET SDWLSTP1=$$GET1^DIQ(44,$$GET1^DIQ(409.32,SDWLSCL,.01,"I"),8,"I")
+10 IF SDWLSTOP=SDWLSTP1
SET SDWLOPT=3
QUIT
+11 KILL DIR
+12 SET DIR(0)="Y"
+13 SET TMP(0)=1
SET TMP(1,0)=$$GET1^DIQ(409.32,SDWLSC,.01)_" and "_SDWLSC1X_" have different stop codes."
+14 DO COL80^SDWLIFT(.TMP)
FOR SDWLI=1:1:TMP(0)
SET DIR("A",SDWLI)=TMP(SDWLI,0)
+15 SET DIR("A")="Do you want to proceed?"
+16 SET DIR("B")="NO"
DO ^DIR
+17 ; +Y=0: SDWLOPT=0; Y=1: SDWLOPT=3
SET SDWLOPT=Y*3
+18 QUIT
+19 ;
P3 ; Comment
+1 DO P4^SDWLE6
+2 QUIT
+3 ;
P4 ; Display data and confirm.
+1 NEW DIR,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLEEST,Y
+2 DO GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;27","I","SDWLTMP")
+3 SET SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
+4 SET SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
+5 SET SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
+6 SET SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
+7 SET SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
+8 SET DIR(0)="Y"
+9 SET DIR("A",1)="The following EWL entry will be created"
+10 SET Y=SDWLORDT
DO DD^%DT
+11 SET DIR("A",2)="Originating Date: "_Y
+12 SET DIR("A",3)="Institution: "_$$GET1^DIQ(4,SDWLIN1,.01)
+13 SET DIR("A",4)="Wait List Type: SPECIFIC CLINIC"
+14 SET DIR("A",5)="Clinic: "_SDWLSC1X
+15 SET Y=SDWLDDT
DO DD^%DT
+16 ; SD*5.3*645 - replaced Desired Date with CID/Preferred date
+17 ;S DIR("A",6)="Desired Date of Appointment: "_Y
+18 SET DIR("A",6)="CID/Preferred Date of Appointment: "_Y
+19 SET DIR("A",7)="Comments: "_SDWLCM
+20 SET DIR("A")="Continue?"
+21 SET DIR("B")="YES"
+22 DO ^DIR
+23 SET SDWLOPT=0
+24 if 'Y
QUIT
+25 IF '$$UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
SET SDWLOPT=3
+26 QUIT
UPDATE(SDWLDFN,SDWLORDT,SDWLIN,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA) ; Create new EWL entry
+1 NEW DA,DIC,DIE,DR,X
+2 SET DIC(0)="LX"
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+3 ; This file has just been created. Is it neurotic to code for the possibility of a lock from elsewhere?
LOCK +^SDWL(409.3,DA):1
+4 IF '$TEST
WRITE !,"Unable to acquire a lock on the Wait List file"
QUIT 0
+5 SET DIE=DIC
+6 SET DR="1////^S X=SDWLORDT"
+7 SET DR=DR_";2////^S X=SDWLIN"
+8 SET DR=DR_";4////^S X=4"
+9 SET DR=DR_";8////^S X=SDWLSCL"
+10 SET DR=DR_";9////^S X=DUZ"
+11 SET DR=DR_";14////^S X=SDWLSCPG"
+12 SET DR=DR_";15////^S X=SDWLSCPR"
+13 SET DR=DR_";22////^S X=SDWLDDT"
+14 SET DR=DR_";23////^S X=""O"""
+15 SET DR=DR_";25////^S X=SDWLCM"
+16 SET DR=DR_";27////^S X=SDWLEEST"
+17 SET DR=DR_";37////^S X=SDWLDA"
+18 DO ^DIE
+19 LOCK -^SDWL(409.3,DA)
+20 SET SDWLERR=0
+21 QUIT 1
