- SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
- ;;5.3;scheduling;**280,491,1015**;AUG 13 1993;Build 21
- ;
- ;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
- SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
- +1 ;;5.3;scheduling;**280,491,1015**;AUG 13 1993;Build 21
- +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
