source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU3.m@ 1147

Last change on this file since 1147 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 2.9 KB
Line 
1SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03
2 ;;5.3;scheduling;**280**;AUG 13 1993
3 ;
4 ;
5 ;
63 ;service specialty edit
7 S SDWLSS="",SDWLINS="",SDWLERR=""
8 F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1
9 .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1
10 ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS
11 ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01)
12 ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1)
13 ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME
14 ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL
15 S WLTC3=""
16 Q
17SEL ;select new Insitition
18 N DIR
19 S DIR("A")="Select Institution: "
20 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
21 I X["^" S SDWLERR=1 Q
22 I Y<1 W *7,"Invalid Entry" G SEL
23 S SDWLINSN=+Y
24 D C3,C31 K DIC,D0,D1
25 Q
26C3 ;
27 ;check entry to see if it already exist
28 S DA=SDWLSSX,DA(1)=SDWLSS
29 I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D
30 . W !,"Institution already exists for this Specialty...deleting."
31 . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK
32 E D
33 . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE
34 K DA,DA(1),DR,DIE,DIK
35 Q
36C31 ;update SD WAIT LIST PATIENT file 409.3
37 S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D
38 .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
39 .K DR,DIE,DA
40 .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA)
41 Q
424 ;specific clinic edit
43 S SDWLSC="",SDWLINS="",SDWLERR=""
44 F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1
45 .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D Q:SDWLERR=1
46 ..S SDWLSCX=$P(^SDWL(409.32,SDWLSC,0),U,1)
47 ..S SDWLINSN=$P($G(^SC(SDWLSCX,0)),U,4),X=$$GET1^DIQ(4,SDWLINSN_",",11) I X'["N"!('$$TF^XUAF4(SDWLINSN)) D SEL1
48 ..;Check 409.32
49 ..I $P(^SDWL(409.32,SDWLSC,0),U,6)'=SDWLINSN D
50 ...K ^SDWL(409.32,"C",SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)=""
51 ...S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN
52 ..D C41
53 S WLTC4=""
54 K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
55 Q
56C41 ;update wait list file
57 S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D
58 .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG")
59 .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN
60 Q
61SEL1 ;select valid institution
62 N DIR
63 W !!,"Invalid Institution. Please select a National Institution.",!
64 W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01)
65 S DIR("A")="Select Institution: "
66 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
67 I X["^" S SDWLERR=1 Q
68 I Y<1 W *7,"Invalid Entry" G SEL1
69 S SDWLINSN=+Y
70 Q
Note: See TracBrowser for help on using the repository browser.