SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53
;
;modify update of 409.32 and related 409.3 with a proper institution set up in file 44
;through the division path
;
3 ;service specialty edit
S SDWLSS="",SDWLINS="",SDWLERR=""
F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1
.F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1
..I '$D(SDWLSSV) S SDWLSSV=SDWLSS
..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01)
..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1)
..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME
..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL
S WLTC3=""
Q
SEL ;select new Insitition
N DIR
S DIR("A")="Select Institution: "
S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
I X["^" S SDWLERR=1 Q
I Y<1 W *7,"Invalid Entry" G SEL
S SDWLINSN=+Y
D C3,C31 K DIC,D0,D1
Q
C3 ;
;check entry to see if it already exist
S DA=SDWLSSX,DA(1)=SDWLSS
I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D
. W !,"Institution already exists for this Specialty...deleting."
. S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK
E D
. W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
K DA,DA(1),DR,DIE,DIK
Q
C31 ;update SD WAIT LIST PATIENT file 409.3
S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D
.S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
.K DR,DIE,DA
.K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA)
Q
4 ;specific clinic edit
N SDWLERR,SDWLSC,SDWLINS S SDWLSC="",SDWLINS="",SDWLERR=""
F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D
.F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D UPDINS^SDWLCU5(SDWLSC,.SDWLERR)
Q:SDWLERR
S WLTC4=""
K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
Q
C41 ;update wait list file
S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D
.S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG")
.K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN
Q
SEL1 ;select valid institution
N DIR
W !!,"Invalid Institution. Please select a National Institution.",!
W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01)
S DIR("A")="Select Institution: "
S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
I X["^" S SDWLERR=1 Q
I Y<1 W *7,"Invalid Entry" G SEL1
S SDWLINSN=+Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLCU3 2723 printed Nov 22, 2024@18:12:08 Page 2
SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
+1 ;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53
+2 ;
+3 ;modify update of 409.32 and related 409.3 with a proper institution set up in file 44
+4 ;through the division path
+5 ;
3 ;service specialty edit
+1 SET SDWLSS=""
SET SDWLINS=""
SET SDWLERR=""
+2 FOR
SET SDWLINS=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS))
if SDWLINS=""
QUIT
Begin DoDot:1
+3 FOR
SET SDWLSS=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS))
if SDWLSS=""
QUIT
Begin DoDot:2
+4 IF '$DATA(SDWLSSV)
SET SDWLSSV=SDWLSS
+5 SET NAME=$$GET1^DIQ(4,SDWLINS_",",.01)
+6 SET SDWLSSN=$PIECE(^SDWL(409.31,SDWLSS,0),U,1)
+7 WRITE !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME
+8 SET SDWLSSX=$ORDER(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0))
if SDWLSSX'=""
DO SEL
End DoDot:2
if SDWLERR=1
QUIT
End DoDot:1
if SDWLERR=1
QUIT
+9 SET WLTC3=""
+10 QUIT
SEL ;select new Insitition
+1 NEW DIR
+2 SET DIR("A")="Select Institution: "
+3 SET DIR(0)="PAO^4:EMZ"
SET DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)"
DO ^DIR
+4 IF X["^"
SET SDWLERR=1
QUIT
+5 IF Y<1
WRITE *7,"Invalid Entry"
GOTO SEL
+6 SET SDWLINSN=+Y
+7 DO C3
DO C31
KILL DIC,D0,D1
+8 QUIT
C3 ;
+1 ;check entry to see if it already exist
+2 SET DA=SDWLSSX
SET DA(1)=SDWLSS
+3 IF $ORDER(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0))
Begin DoDot:1
+4 WRITE !,"Institution already exists for this Specialty...deleting."
+5 SET DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_","
DO ^DIK
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 WRITE !
SET DR=".01////^S X=SDWLINSN"
SET DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_","
DO ^DIE
End DoDot:1
+8 KILL DA,DA(1),DR,DIE,DIK
+9 QUIT
C31 ;update SD WAIT LIST PATIENT file 409.3
+1 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA))
if SDWLDA=""
QUIT
Begin DoDot:1
+2 SET DR="2////^S X=SDWLINSN"
SET DIE="^SDWL(409.3,"
SET DA=SDWLDA
DO ^DIE
+3 KILL DR,DIE,DA
+4 KILL ^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($JOB,"EWL",$JOB,SDWLDA)
End DoDot:1
+5 QUIT
4 ;specific clinic edit
+1 NEW SDWLERR,SDWLSC,SDWLINS
SET SDWLSC=""
SET SDWLINS=""
SET SDWLERR=""
+2 FOR
SET SDWLINS=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS))
if SDWLINS=""
QUIT
Begin DoDot:1
+3 FOR
SET SDWLSC=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC))
if SDWLSC=""
QUIT
DO UPDINS^SDWLCU5(SDWLSC,.SDWLERR)
End DoDot:1
+4 if SDWLERR
QUIT
+5 SET WLTC4=""
+6 KILL ^SDWL(409.32,"ACT")
SET DIK="^SDWL(409.32,"
DO IXALL^DIK
+7 QUIT
C41 ;update wait list file
+1 SET SDWLDA=""
FOR
SET SDWLDA=$ORDER(^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA))
if SDWLDA=""
QUIT
Begin DoDot:1
+2 SET SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN
DO UPDATE^DIE("","SDWLIN","SDWLMSG")
+3 KILL ^TMP($JOB,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($JOB,"EWL",$JOB,SDWLDA),SDWLIN
End DoDot:1
+4 QUIT
SEL1 ;select valid institution
+1 NEW DIR
+2 WRITE !!,"Invalid Institution. Please select a National Institution.",!
+3 WRITE "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01)
+4 SET DIR("A")="Select Institution: "
+5 SET DIR(0)="PAO^4:EMZ"
SET DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)"
DO ^DIR
+6 IF X["^"
SET SDWLERR=1
QUIT
+7 IF Y<1
WRITE *7,"Invalid Entry"
GOTO SEL1
+8 SET SDWLINSN=+Y
+9 QUIT
