source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m@ 619

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

initial load of WorldVistAEHR
File size: 6.6 KB
Line 
1SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 ; Compiled August 20, 2007 17:04:58
2 ;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53
3EN ;
4 W !!,"Checking file 404.51 one last time.",!
5 S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1
6 . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
7 . S CODE=$$GET1^DIQ(4,INST_",",11,"I")
8 . S INCK=$$TF^XUAF4(INST)
9 . I CODE'="N"!('INCK) D
10 .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: "
11 .. W $$GET1^DIQ(4,INST_",",.01)
12 .. D EDIT^SDWLCU2
13 Q:SDWLERR=1
14 ;
15 W !!,"Checking file 409.31 one last time.",!
1640931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1
17 . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1
18 .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
19 .. S INCK=$$TF^XUAF4(SDWLINS)
20 .. I CODE'="N"!('INCK) D
21 ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: "
22 ... W $$GET1^DIQ(4,SDWLINS_",",.01)
23 ... D GETINS Q:SDWLERR=1
24 ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1
25 .... D C3^SDWLCU3
26 Q:SDWLERR=1
2740932 W !!,"Checking file 409.32 one last time.",!
28 N INERROR S INERROR="" S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D UPDINS(SDWLSC,.INERROR)
29 Q:INERROR=1
30 N DIK S DIK="^SDWL(409.32," D IXALL^DIK
31 W !!,"Checking file 409.3 one last time.",!
32 S SDWLERR=""
33 S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1
34 .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5)
35 .Q:'SDWLTY!'SDWLINST
36 .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI
37 .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG
38 W !,"Done."
39 Q
40UPDINS(SDWLSC,INERROR) ; update 409.32 and the related entroes in 409.3
41 N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32
42 ;check set up in file 44
43 ;get clinic
44 N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01)
45 N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL)
46 S SDWMES=SDWMES_$P(STR,U,6)
47 I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. "
48 I SDWMES'="" D Q
49 .W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **"
50 .W !!,SDWMES
51 .W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY."
52 .W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP."
53 .S:INERROR="" INERROR=1 Q
54 I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D
55 .W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99)
56 .W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2)
57 .W !!,"EWL set up will be updated with the Clinic from the Hospital Location file,"
58 .W !,"and the related open EWL entries will be updated as well."
59 .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC
60 .L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q
61 .D ^DIE L -^SDWL(409.32,DA)
62 .;loop to update EWL entries in FILE 409.3 if any
63 .N SCL,DA,DR,CNT S SCL="",CNT=0 F S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0 D
64 ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q
65 ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL
66 ..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q
67 ..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1
68 .I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated."
69 N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D
70 .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q
71 .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user
72 .D ^DIE L -^SDWL(409.32,SDWLSC)
73 .W !,"EWL Clinic entry for "_CLN_" updated with today's activation date."
74 Q
75CHK1 ;CHECK FOR INSTITUTION VALIDILITY
76 S SDWLERR=0
77 I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)=""
78 I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q
79 K ^TMP($J,"SDWLCU5",$J,"B")
80 I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q
81 I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q
82 W !,"Please select a valid Institution for this record from the following list for",!
83 D DIS
84 S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D
85 .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C
86CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR
87 I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q
88 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
89CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
90 S TAG="CHK"
91 Q
92CHK3 ;
93 S SDWLERR=""
94 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8)
95 Q:'SDWLI!'$D(^SDWL(409.31,SDWLI))
96 I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1
97 .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)=""
98 .I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q
99 .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q
100 .W !,"Please select a valid Institution for this record from the following list for",!
101 .D DIS
102 .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D
103 ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
104 ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
105 .W ! S DIR(0)="NO^1:"_C D ^DIR
106 .I $D(DUOUT)!(Y="") S SDWLERR=1 Q
107 .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
108 .D CHE3
109 Q
110CHE3 ;
111 G CHK3:Y<0
112 S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
113 S TAG="CHK"
114 Q
115CHK4 ;
116 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9)
117 Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0))
118 I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D
119 .D DIS
120 .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
121 Q
122CHK2 ;
123 S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7)
124 I SDWLINST'=SDWLINSN D
125 .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
126 S TAG="CHK"
127 Q
128DIS ;display record
129 S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
130 S SSN=$$GET1^DIQ(2,NN_",",.09)
131 W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!!
132 Q
133GETINS ;Get institution
134 N DIR
135 S DIR("A")="Select Institution: "
136 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR
137 I X["^" S SDWLERR=1 Q
138 I Y<1 W *7,"Invalid Entry" G GETINS
139 S SDWLINSN=+Y
140 Q
Note: See TracBrowser for help on using the repository browser.