SDWLBACC ;;IOFO BAY PINES/OG - BATCH CHANGE EWL CLINIC ; Compiled August 14, 2007 11:20:57
;;5.3;scheduling;**446**;AUG 13 1993;Build 77
;
; ******************************************************************
; CHANGE LOG
;
; DATE PATCH DESCRIPTION
; ---- ----- -----------
;
;
N SDWLERR,SDWLOPT,SDWLSCL,SDWLHD,SDWLIN1,SDWLIN2,SDWLCL0,SDWLCL1,SDWLCL2,SDWLCSC1,SDWLCSC2,SDWLCM
S SDWLHD="Scheduling/PCMM Batch Change EWL Clinic"
W:$D(IOF) @IOF W !?80-$L(SDWLHD)\2,SDWLHD,!
S SDWLERR=0,SDWLOPT=1,(SDWLIN2,SDWLCL1,SDWLCL2,SDWLCM)="",SDWLIN1=+$$SITE^VASITE()
F D @("P"_SDWLOPT) Q:'SDWLOPT
Q
P1 ; Source Institution
S DIR(0)="PAO^DIC(4,:EMNZ"
S DIR("A")="Select Source Institution: "
I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN1,.01)
S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
D ^DIR
I Y<1 S SDWLOPT=0 Q
S (SDWLIN1,SDWLIN2)=+Y,SDWLOPT=SDWLOPT+1
Q
P2 ; Source Clinic
N DIR,SDWLSC
S DIR(0)="PAO^SDWL(409.32,:EMNZ"
S DIR("A")="Select Source Clinic: "
I SDWLCL1'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL1,.01)
S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN1"
D ^DIR
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=SDWLOPT-1 Q
S SDWLCL0=+Y ; Wait list specific clinic
S SDWLCL1=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
S SDWLCSC1=$$GET1^DIQ(44,SDWLCL1,8,"I")_U_$$GET1^DIQ(44,SDWLCL1,8) ; Clinic stop code
S SDWLOPT=SDWLOPT+1
Q
P3 ; Destination Institution
S DIR(0)="PAO^DIC(4,:EMNZ"
S DIR("A")="Select Destination Institution: "
I SDWLIN1'="" S DIR("B")=$$GET1^DIQ(4,SDWLIN2,.01)
S DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
D ^DIR
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=SDWLOPT-1 Q
S SDWLIN2=+Y,SDWLOPT=SDWLOPT+1
Q
P4 ; Destination Clinic
N DIR,SDWLSC,SDWLY
S DIR(0)="PAO^SDWL(409.32,:EMNZ"
S DIR("A")="Select Destination Clinic: "
I SDWLCL2'="" S DIR("B")=$$GET1^DIQ(409.32,SDWLCL2,.01)
S DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN2,+Y'=SDWLCL0"
D ^DIR
I Y="^" S SDWLOPT=0 Q
I Y<1 S SDWLOPT=SDWLOPT-1 Q
S SDWLY=+Y,SDWLSC=$P(Y,U,2) ; pointer to HOSPITAL LOCATION file
; get clinic's stop code. warn if different.
S SDWLCSC2=$$GET1^DIQ(44,SDWLSC,8,"I")_U_$$GET1^DIQ(44,SDWLSC,8) ; Clinic's stop code
I +SDWLCSC1'=+SDWLCSC2 D Q:'Y
.S DIR(0)="Y"
.S DIR("A")="The clinics' stop codes are different, continue"
.S DIR("A",1)=$$GET1^DIQ(409.32,SDWLCL1,.01)_": "_$P(SDWLCSC1,U,2)_" ("_+SDWLCSC1_")"
.S DIR("A",2)=$$GET1^DIQ(409.32,+Y,.01)_": "_$P(SDWLCSC2,U,2)_" ("_+SDWLCSC2_")"
.S DIR("B")="YES"
.D ^DIR
.S:Y="^" SDWLOPT=0
.Q
S SDWLSCL=SDWLY,SDWLOPT=SDWLOPT+1
Q
P5 ; Comment
D P4^SDWLE6
Q
P6 ; Confirmation and processing
N DIR,Y
S DIR(0)="Y"
S DIR("A")="Proceed with batch clinic change"
S DIR("B")="YES"
D ^DIR
D:Y CHNGCL
S SDWLOPT=0
Q
CHNGCL ;
N DIR,SDWLDA,SDWLCNT
S SDWLDA="",SDWLCNT=0
F S SDWLDA=$O(^SDWL(409.3,"SC",SDWLCL1,SDWLDA)) Q:'SDWLDA D
.N DA,DIE,DIR,DR,SDWLDFN,SDWLIN,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLCL1,SDWLDDT,SDWLEEST,Y
.D GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;23;27","I","SDWLTMP")
.Q:SDWLTMP(409.3,SDWLDA_",",23,"I")="C" ; Only open entries.
.S SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
.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")
.Q:'$$UPDATE^SDWLE7(SDWLDFN,SDWLORDT,SDWLIN2,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
.; disposition old entry
.S DIE="^SDWL(409.3,",DA=SDWLDA,DR="19////^S X=DT;20////^S X=DUZ;21////^S X=""CL"";23////^S X=""C"""
.D ^DIE
.S SDWLCNT=SDWLCNT+1
.Q
W ! W:SDWLCNT "Clinics changed. " W SDWLCNT," entries processed."
S DIR(0)="E" D ^DIR
Q
CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
; function to return:
; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ Inst Name _U_ Div Pointer to ^DG(40.8 _U_N/L_U_Message
; ( INST^STA NUM^SNAM^DIV^N/L^MESS )
; N/L - N -National/L -Local
; with Message:
; - if STA="" INST^^SNAM^DIV^^N/L^' - No Station Number on file'
; or
; - 0^^^DIV^^' - No Institution has been identified'
; - 0^^^-1^^' - no Division has been identified'
; - -1 no clinic on file'
I '$D(^SC(+CL)) Q -1_"^^^^^no clinic on file"
N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN=""
S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
I DIV=0 S SDWMES="no Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES
S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
I INS=0 S SDWMES="No Institution has been identified" Q 0_"^^^"_DIV_"^"_SDWMES
E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name
I STN="" S SDWMES="No Station Number on file"
I '$$TF^XUAF4(INS) S SDWMES="Inactive treating medical facility"
S SNL=$$GET1^DIQ(4,INS_",",11,"I")
Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLBACC 5169 printed Oct 16, 2024@19:02:37 Page 2
SDWLBACC ;;IOFO BAY PINES/OG - BATCH CHANGE EWL CLINIC ; Compiled August 14, 2007 11:20:57
+1 ;;5.3;scheduling;**446**;AUG 13 1993;Build 77
+2 ;
+3 ; ******************************************************************
+4 ; CHANGE LOG
+5 ;
+6 ; DATE PATCH DESCRIPTION
+7 ; ---- ----- -----------
+8 ;
+9 ;
+10 NEW SDWLERR,SDWLOPT,SDWLSCL,SDWLHD,SDWLIN1,SDWLIN2,SDWLCL0,SDWLCL1,SDWLCL2,SDWLCSC1,SDWLCSC2,SDWLCM
+11 SET SDWLHD="Scheduling/PCMM Batch Change EWL Clinic"
+12 if $DATA(IOF)
WRITE @IOF
WRITE !?80-$LENGTH(SDWLHD)\2,SDWLHD,!
+13 SET SDWLERR=0
SET SDWLOPT=1
SET (SDWLIN2,SDWLCL1,SDWLCL2,SDWLCM)=""
SET SDWLIN1=+$$SITE^VASITE()
+14 FOR
DO @("P"_SDWLOPT)
if 'SDWLOPT
QUIT
+15 QUIT
P1 ; Source Institution
+1 SET DIR(0)="PAO^DIC(4,:EMNZ"
+2 SET DIR("A")="Select Source Institution: "
+3 IF SDWLIN1'=""
SET DIR("B")=$$GET1^DIQ(4,SDWLIN1,.01)
+4 SET DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
+5 DO ^DIR
+6 IF Y<1
SET SDWLOPT=0
QUIT
+7 SET (SDWLIN1,SDWLIN2)=+Y
SET SDWLOPT=SDWLOPT+1
+8 QUIT
P2 ; Source Clinic
+1 NEW DIR,SDWLSC
+2 SET DIR(0)="PAO^SDWL(409.32,:EMNZ"
+3 SET DIR("A")="Select Source Clinic: "
+4 IF SDWLCL1'=""
SET DIR("B")=$$GET1^DIQ(409.32,SDWLCL1,.01)
+5 SET DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN1"
+6 DO ^DIR
+7 IF Y="^"
SET SDWLOPT=0
QUIT
+8 IF Y<1
SET SDWLOPT=SDWLOPT-1
QUIT
+9 ; Wait list specific clinic
SET SDWLCL0=+Y
+10 ; pointer to HOSPITAL LOCATION file
SET SDWLCL1=$PIECE(Y,U,2)
+11 ; Clinic stop code
SET SDWLCSC1=$$GET1^DIQ(44,SDWLCL1,8,"I")_U_$$GET1^DIQ(44,SDWLCL1,8)
+12 SET SDWLOPT=SDWLOPT+1
+13 QUIT
P3 ; Destination Institution
+1 SET DIR(0)="PAO^DIC(4,:EMNZ"
+2 SET DIR("A")="Select Destination Institution: "
+3 IF SDWLIN1'=""
SET DIR("B")=$$GET1^DIQ(4,SDWLIN2,.01)
+4 SET DIR("S")="I $E($$GET1^DIQ(4,+Y,99),1,3)=$E(+$P($$SITE^VASITE(),U,3),1,3)"
+5 DO ^DIR
+6 IF Y="^"
SET SDWLOPT=0
QUIT
+7 IF Y<1
SET SDWLOPT=SDWLOPT-1
QUIT
+8 SET SDWLIN2=+Y
SET SDWLOPT=SDWLOPT+1
+9 QUIT
P4 ; Destination Clinic
+1 NEW DIR,SDWLSC,SDWLY
+2 SET DIR(0)="PAO^SDWL(409.32,:EMNZ"
+3 SET DIR("A")="Select Destination Clinic: "
+4 IF SDWLCL2'=""
SET DIR("B")=$$GET1^DIQ(409.32,SDWLCL2,.01)
+5 SET DIR("S")="S X=$$GET1^DIQ(409.32,+Y,.01,""I"") I $P($$CLIN^SDWLBACC(X),U)=SDWLIN2,+Y'=SDWLCL0"
+6 DO ^DIR
+7 IF Y="^"
SET SDWLOPT=0
QUIT
+8 IF Y<1
SET SDWLOPT=SDWLOPT-1
QUIT
+9 ; pointer to HOSPITAL LOCATION file
SET SDWLY=+Y
SET SDWLSC=$PIECE(Y,U,2)
+10 ; get clinic's stop code. warn if different.
+11 ; Clinic's stop code
SET SDWLCSC2=$$GET1^DIQ(44,SDWLSC,8,"I")_U_$$GET1^DIQ(44,SDWLSC,8)
+12 IF +SDWLCSC1'=+SDWLCSC2
Begin DoDot:1
+13 SET DIR(0)="Y"
+14 SET DIR("A")="The clinics' stop codes are different, continue"
+15 SET DIR("A",1)=$$GET1^DIQ(409.32,SDWLCL1,.01)_": "_$PIECE(SDWLCSC1,U,2)_" ("_+SDWLCSC1_")"
+16 SET DIR("A",2)=$$GET1^DIQ(409.32,+Y,.01)_": "_$PIECE(SDWLCSC2,U,2)_" ("_+SDWLCSC2_")"
+17 SET DIR("B")="YES"
+18 DO ^DIR
+19 if Y="^"
SET SDWLOPT=0
+20 QUIT
End DoDot:1
if 'Y
QUIT
+21 SET SDWLSCL=SDWLY
SET SDWLOPT=SDWLOPT+1
+22 QUIT
P5 ; Comment
+1 DO P4^SDWLE6
+2 QUIT
P6 ; Confirmation and processing
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Proceed with batch clinic change"
+4 SET DIR("B")="YES"
+5 DO ^DIR
+6 if Y
DO CHNGCL
+7 SET SDWLOPT=0
+8 QUIT
CHNGCL ;
+1 NEW DIR,SDWLDA,SDWLCNT
+2 SET SDWLDA=""
SET SDWLCNT=0
+3 FOR
SET SDWLDA=$ORDER(^SDWL(409.3,"SC",SDWLCL1,SDWLDA))
if 'SDWLDA
QUIT
Begin DoDot:1
+4 NEW DA,DIE,DIR,DR,SDWLDFN,SDWLIN,SDWLTMP,SDWLORDT,SDWLSCPG,SDWLSCPR,SDWLCL1,SDWLDDT,SDWLEEST,Y
+5 DO GETS^DIQ(409.3,SDWLDA_",","1;14;15;22;23;27","I","SDWLTMP")
+6 ; Only open entries.
if SDWLTMP(409.3,SDWLDA_",",23,"I")="C"
QUIT
+7 SET SDWLDFN=$$GET1^DIQ(409.3,SDWLDA,.01,"I")
+8 SET SDWLORDT=SDWLTMP(409.3,SDWLDA_",",1,"I")
+9 SET SDWLSCPG=SDWLTMP(409.3,SDWLDA_",",14,"I")
+10 SET SDWLSCPR=SDWLTMP(409.3,SDWLDA_",",15,"I")
+11 SET SDWLDDT=SDWLTMP(409.3,SDWLDA_",",22,"I")
+12 SET SDWLEEST=SDWLTMP(409.3,SDWLDA_",",27,"I")
+13 if '$$UPDATE^SDWLE7(SDWLDFN,SDWLORDT,SDWLIN2,SDWLSCL,SDWLSCPG,SDWLSCPR,SDWLDDT,SDWLCM,SDWLEEST,SDWLDA)
QUIT
+14 ; disposition old entry
+15 SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
SET DR="19////^S X=DT;20////^S X=DUZ;21////^S X=""CL"";23////^S X=""C"""
+16 DO ^DIE
+17 SET SDWLCNT=SDWLCNT+1
+18 QUIT
End DoDot:1
+19 WRITE !
if SDWLCNT
WRITE "Clinics changed. "
WRITE SDWLCNT," entries processed."
+20 SET DIR(0)="E"
DO ^DIR
+21 QUIT
CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path.
+1 ; function to return:
+2 ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ Inst Name _U_ Div Pointer to ^DG(40.8 _U_N/L_U_Message
+3 ; ( INST^STA NUM^SNAM^DIV^N/L^MESS )
+4 ; N/L - N -National/L -Local
+5 ; with Message:
+6 ; - if STA="" INST^^SNAM^DIV^^N/L^' - No Station Number on file'
+7 ; or
+8 ; - 0^^^DIV^^' - No Institution has been identified'
+9 ; - 0^^^-1^^' - no Division has been identified'
+10 ; - -1 no clinic on file'
+11 IF '$DATA(^SC(+CL))
QUIT -1_"^^^^^no clinic on file"
+12 NEW SDWMES,STN,DIV,INS,SNL,STR,SNAM
SET SDWMES=""
SET STN=""
+13 SET DIV=+$$GET1^DIQ(44,CL_",",3.5,"I")
+14 IF DIV=0
SET SDWMES="no Division has been identified"
QUIT 0_"^^^"_-1_"^^"_SDWMES
+15 SET INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I")
+16 IF INS=0
SET SDWMES="No Institution has been identified"
QUIT 0_"^^^"_DIV_"^"_SDWMES
+17 ;station number and name
IF '$TEST
SET STR=$$NS^XUAF4(INS)
SET STN=$PIECE(STR,U,2)
SET SNAM=$PIECE(STR,U)
+18 IF STN=""
SET SDWMES="No Station Number on file"
+19 IF '$$TF^XUAF4(INS)
SET SDWMES="Inactive treating medical facility"
+20 SET SNL=$$GET1^DIQ(4,INS_",",11,"I")
+21 QUIT INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES
