SDWLE2 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled May 25, 2007 16:37:21
;;5.3;scheduling;**263,397,424,446,1015**;AUG 13 1993;Build 21
;
;
;******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
; 06/06/06 SD*5.3*446 Allow selection of a clinic after specialty is entered
;
;
;
;Service/Specialty sub-routine
;
EN ;
N SDWLSSX ; sd/446
K DIR,DIC,DR I $D(SDWLSS) S X=$$EXTERNAL^DILFD(409.3,7,,SDWLSS)
S SDWLERR=0 I $D(SDWLSS) S DIC("B")=$S($D(SDWLSS):X,1:"") I DIC("B")="" K DIC("B")
S DIC(0)="AEQ",DIC=409.31,DIC("A")="Select Service/Specialty: "
S DIC("S")="I $D(^SDWL(409.31,""E"",SDWLINE,+Y)),$D(^SDWL(409.31,+Y,""I"")),$P(^SDWL(409.31,+Y,""I"",($O(^SDWL(409.31,+Y,""I"",""B"",SDWLINE,""""))),0),U,4)=""""" D ^DIC
I X["^" S DUOUT=1 G END
I Y<0 W *7," Required" G EN
S SDWLSSX=+Y ; sd/446
N SDSP S SDSP=$$GET1^DIQ(409.31,SDWLSSX,.01,"I") ; get pointer to 40.7
N SDD,SDCL,SDORG S SDCL="",SDORG=DT S SDD=$$CHKENC^SDWLQSC1(DFN,SDORG,SDCL,SDSP,1)
I SDD D APPTDIS N DIR,Y D I Y["^"!'Y S DUOUT=1 Q
.W !!,"This patient already has scheduled appointments which may match",!,"the Wait List Entry."
.S DIR(0)="Y^A0",DIR("B")="NO",DIR("A")="Are you sure you want to continue"
.D ^DIR
;
I '$$CLIN() Q:$G(DUOUT) S DIE="^SDWL(409.3,",DR="7////^S X=SDWLSSX" D ^DIE ; sd/446
K DIR,DIC,DIE,DR,Y,DUOUT
END Q
APPTDIS ;display already created appt/encounters
;from ^TMP($J,"APPT")
N STR,SCNT
Q:'$D(^TMP($J,"APPT"))
S SCNT="" F S SCNT=$O(^TMP($J,"APPT",SCNT)) Q:SCNT="" D
.S STR=^TMP($J,"APPT",SCNT)
.N ZZ F ZZ=2,3,4,10,15 S SDD(ZZ)=$P($P(STR,"^",ZZ),";",2)
.N SD S SD=$P(STR,U) D S Y=SD D D^DIQ S SDD(1)=Y ; date conv
..I SDD(3)="SCHEDULED/KEPT" S SDD(3)=$S(SD<DT:"KEPT",1:"SCHEDULED")
.;DISPLAY
.I SCNT=1 D DPH(SCNT,.SDD)
.D DPHD(SCNT,.SDD)
Q
DPH(SCNT,SDD) ;display appt header
W !!,"Appointment(s) for: "_SDD(4)
W !?3,"Appt Date/Time",?23,"Clinic",?48,"Status",?60,"Institution",! N SDL S $P(SDL,"-",79)="" W SDL,!
Q
DPHD(SCNT,SDD) ;
W !,SCNT,?3,SDD(1),?23,$E(SDD(2),1,23),?48,$E(SDD(10),1,10),?60,SDD(15)
Q
;
CLIN() ; sd/446
N DA,DIC,DIE,DIK,DR,SDWLCL,SDWLEST,X,Y
S DIC=409.32,DIC(0)="AEQ",DIC("A")="WL SPECIFIC CLINIC related to this SPECIALTY (optional): ",DIC("S")="I $$VAL^SDWLE2(+Y)"
D ^DIC
I X["^" S DUOUT=1 Q 0
Q:X="" 0
S SDWLCL=+Y
; Need to delete the old entry and create anew to change the wait list type
S SDWLEST=$$GET1^DIQ(409.3,SDWLDA,27,"I")
S DIK="^SDWL(409.3,",DA=SDWLDA
D ^DIK
S DIC(0)="LX",X=SDWLDFN,DIC="^SDWL(409.3," D FILE^DICN
L:DA'=SDWLDA +^SDWL(409.3,DA),-^SDWL(409.3,SDWLDA)
S SDWLDA=DA
S DIE="^SDWL(409.3,",DR="1////^S X=DT;2////^S X=SDWLINE;4////^S X=4;8////^S X=SDWLCL;9////^S X=DUZ;27////^S X=SDWLEST"
S:$G(SDWLACA) DR=DR_";33////^S X=""Y""" ; 446
D ^DIE
Q 1
VAL(Y) ; sd/446
N TMP
D GETS^DIQ(409.32,Y,".01;.02;2;4","I","TMP")
Q:TMP(409.32,Y_",",.02,"I")'=SDWLINE 0 ; Wrong institution
Q:TMP(409.32,Y_",",2,"I")="" 0 ; No activation date entered
Q:TMP(409.32,Y_",",4,"I")'="" 0 ; Inactivation date entered
Q $$GET1^DIQ(44,TMP(409.32,Y_",",.01,"I"),8,"I")=$$GET1^DIQ(409.31,SDWLSSX,.01,"I") ; Does the clinic have the right stop code?
SDWLE2 ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002 2:10 PM ; Compiled May 25, 2007 16:37:21
+1 ;;5.3;scheduling;**263,397,424,446,1015**;AUG 13 1993;Build 21
+2 ;
+3 ;
+4 ;******************************************************************
+5 ; CHANGE LOG
+6 ;
+7 ; DATE PATCH DESCRIPTION
+8 ; ---- ----- -----------
+9 ; 06/06/06 SD*5.3*446 Allow selection of a clinic after specialty is entered
+10 ;
+11 ;
+12 ;
+13 ;Service/Specialty sub-routine
+14 ;
EN ;
+1 ; sd/446
NEW SDWLSSX
+2 KILL DIR,DIC,DR
IF $DATA(SDWLSS)
SET X=$$EXTERNAL^DILFD(409.3,7,,SDWLSS)
+3 SET SDWLERR=0
IF $DATA(SDWLSS)
SET DIC("B")=$SELECT($DATA(SDWLSS):X,1:"")
IF DIC("B")=""
KILL DIC("B")
+4 SET DIC(0)="AEQ"
SET DIC=409.31
SET DIC("A")="Select Service/Specialty: "
+5 SET DIC("S")="I $D(^SDWL(409.31,""E"",SDWLINE,+Y)),$D(^SDWL(409.31,+Y,""I"")),$P(^SDWL(409.31,+Y,""I"",($O(^SDWL(409.31,+Y,""I"",""B"",SDWLINE,""""))),0),U,4)="""""
DO ^DIC
+6 IF X["^"
SET DUOUT=1
GOTO END
+7 IF Y<0
WRITE *7," Required"
GOTO EN
+8 ; sd/446
SET SDWLSSX=+Y
+9 ; get pointer to 40.7
NEW SDSP
SET SDSP=$$GET1^DIQ(409.31,SDWLSSX,.01,"I")
+10 NEW SDD,SDCL,SDORG
SET SDCL=""
SET SDORG=DT
SET SDD=$$CHKENC^SDWLQSC1(DFN,SDORG,SDCL,SDSP,1)
+11 IF SDD
DO APPTDIS
NEW DIR,Y
Begin DoDot:1
+12 WRITE !!,"This patient already has scheduled appointments which may match",!,"the Wait List Entry."
+13 SET DIR(0)="Y^A0"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to continue"
+14 DO ^DIR
End DoDot:1
IF Y["^"!'Y
SET DUOUT=1
QUIT
+15 ;
+16 ; sd/446
IF '$$CLIN()
IF $GET(DUOUT)
QUIT
SET DIE="^SDWL(409.3,"
SET DR="7////^S X=SDWLSSX"
DO ^DIE
+17 KILL DIR,DIC,DIE,DR,Y,DUOUT
END QUIT
APPTDIS ;display already created appt/encounters
+1 ;from ^TMP($J,"APPT")
+2 NEW STR,SCNT
+3 IF '$DATA(^TMP($JOB,"APPT"))
QUIT
+4 SET SCNT=""
FOR
SET SCNT=$ORDER(^TMP($JOB,"APPT",SCNT))
IF SCNT=""
QUIT
Begin DoDot:1
+5 SET STR=^TMP($JOB,"APPT",SCNT)
+6 NEW ZZ
FOR ZZ=2,3,4,10,15
SET SDD(ZZ)=$PIECE($PIECE(STR,"^",ZZ),";",2)
+7 ; date conv
NEW SD
SET SD=$PIECE(STR,U)
Begin DoDot:2
+8 IF SDD(3)="SCHEDULED/KEPT"
SET SDD(3)=$SELECT(SD<DT:"KEPT",1:"SCHEDULED")
End DoDot:2
SET Y=SD
DO D^DIQ
SET SDD(1)=Y
+9 ;DISPLAY
+10 IF SCNT=1
DO DPH(SCNT,.SDD)
+11 DO DPHD(SCNT,.SDD)
End DoDot:1
+12 QUIT
DPH(SCNT,SDD) ;display appt header
+1 WRITE !!,"Appointment(s) for: "_SDD(4)
+2 WRITE !?3,"Appt Date/Time",?23,"Clinic",?48,"Status",?60,"Institution",!
NEW SDL
SET $PIECE(SDL,"-",79)=""
WRITE SDL,!
+3 QUIT
DPHD(SCNT,SDD) ;
+1 WRITE !,SCNT,?3,SDD(1),?23,$EXTRACT(SDD(2),1,23),?48,$EXTRACT(SDD(10),1,10),?60,SDD(15)
+2 QUIT
+3 ;
CLIN() ; sd/446
+1 NEW DA,DIC,DIE,DIK,DR,SDWLCL,SDWLEST,X,Y
+2 SET DIC=409.32
SET DIC(0)="AEQ"
SET DIC("A")="WL SPECIFIC CLINIC related to this SPECIALTY (optional): "
SET DIC("S")="I $$VAL^SDWLE2(+Y)"
+3 DO ^DIC
+4 IF X["^"
SET DUOUT=1
QUIT 0
+5 IF X=""
QUIT 0
+6 SET SDWLCL=+Y
+7 ; Need to delete the old entry and create anew to change the wait list type
+8 SET SDWLEST=$$GET1^DIQ(409.3,SDWLDA,27,"I")
+9 SET DIK="^SDWL(409.3,"
SET DA=SDWLDA
+10 DO ^DIK
+11 SET DIC(0)="LX"
SET X=SDWLDFN
SET DIC="^SDWL(409.3,"
DO FILE^DICN
+12 IF DA'=SDWLDA
LOCK +^SDWL(409.3,DA),-^SDWL(409.3,SDWLDA)
+13 SET SDWLDA=DA
+14 SET DIE="^SDWL(409.3,"
SET DR="1////^S X=DT;2////^S X=SDWLINE;4////^S X=4;8////^S X=SDWLCL;9////^S X=DUZ;27////^S X=SDWLEST"
+15 ; 446
IF $GET(SDWLACA)
SET DR=DR_";33////^S X=""Y"""
+16 DO ^DIE
+17 QUIT 1
VAL(Y) ; sd/446
+1 NEW TMP
+2 DO GETS^DIQ(409.32,Y,".01;.02;2;4","I","TMP")
+3 ; Wrong institution
IF TMP(409.32,Y_",",.02,"I")'=SDWLINE
QUIT 0
+4 ; No activation date entered
IF TMP(409.32,Y_",",2,"I")=""
QUIT 0
+5 ; Inactivation date entered
IF TMP(409.32,Y_",",4,"I")'=""
QUIT 0
+6 ; Does the clinic have the right stop code?
QUIT $$GET1^DIQ(44,TMP(409.32,Y_",",.01,"I"),8,"I")=$$GET1^DIQ(409.31,SDWLSSX,.01,"I")
