Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m
===================================================================
--- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m	(revision 613)
+++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m	(revision 623)
@@ -1,140 +1,114 @@
-SDWLCU5	;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03  ; Compiled August 20, 2007 17:04:58
-	;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53
-EN	;
-	W !!,"Checking file 404.51 one last time.",!
-	S SDWLERR="",TEAM=0 F  S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM  D  Q:SDWLERR=1
-	. S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
-	. S CODE=$$GET1^DIQ(4,INST_",",11,"I")
-	. S INCK=$$TF^XUAF4(INST)
-	. I CODE'="N"!('INCK) D
-	.. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01),"    INSTITUTION: "
-	.. W $$GET1^DIQ(4,INST_",",.01)
-	.. D EDIT^SDWLCU2
-	Q:SDWLERR=1
-	;
-	W !!,"Checking file 409.31 one last time.",!
-40931	S SDWLSS=0 F  S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS  D  Q:SDWLERR=1
-	. S SDWLINS="" F  S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS  D  Q:SDWLERR=1
-	.. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
-	.. S INCK=$$TF^XUAF4(SDWLINS)
-	.. I CODE'="N"!('INCK) D
-	... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01),"    INSTITUTION: "
-	... W $$GET1^DIQ(4,SDWLINS_",",.01)
-	... D GETINS Q:SDWLERR=1
-	... S SDWLSSX="" F  S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX  D  Q:SDWLERR=1
-	.... D C3^SDWLCU3
-	Q:SDWLERR=1
-40932	W !!,"Checking file 409.32 one last time.",!
-	N INERROR S INERROR="" S SDWLSC=0 F  S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC  D UPDINS(SDWLSC,.INERROR)
-	Q:INERROR=1
-	N DIK S DIK="^SDWL(409.32," D IXALL^DIK
-	W !!,"Checking file 409.3 one last time.",!
-	S SDWLERR=""
-	S SDWLDA=0,TAG="CHK" F  S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1  D  Q:SDWLERR=1
-	.S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5)
-	.Q:'SDWLTY!'SDWLINST
-	.S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI
-	.S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG
-	W !,"Done."
-	Q
-UPDINS(SDWLSC,INERROR)	; update 409.32 and the related entroes in 409.3
-	N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32
-	;check set up in file 44
-	;get clinic
-	N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01)
-	N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL)
-	S SDWMES=SDWMES_$P(STR,U,6)
-	I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. "
-	I SDWMES'="" D  Q
-	.W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **"
-	.W !!,SDWMES
-	.W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY."
-	.W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP."
-	.S:INERROR="" INERROR=1 Q
-	I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D
-	.W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99)
-	.W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2)
-	.W !!,"EWL set up will be updated with the Clinic from the Hospital Location file,"
-	.W !,"and the related open EWL entries will be updated as well."
-	.N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC
-	.L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q
-	.D ^DIE L -^SDWL(409.32,DA)
-	.;loop to update EWL entries in FILE 409.3 if any
-	.N SCL,DA,DR,CNT S SCL="",CNT=0 F  S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0  D
-	..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q
-	..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL
-	..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q
-	..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1
-	.I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated."
-	N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D
-	.S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q
-	.S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user
-	.D ^DIE L -^SDWL(409.32,SDWLSC)
-	.W !,"EWL Clinic entry for "_CLN_" updated with today's activation date."
-	Q
-CHK1	;CHECK FOR INSTITUTION VALIDILITY
-	S SDWLERR=0
-	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)=""
-	I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q
-	K ^TMP($J,"SDWLCU5",$J,"B")
-	I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q
-	I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q
-	W !,"Please select a valid Institution for this record from the following list for",!
-	D DIS
-	S C=0,SDWLI="" F  S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1  D
-	.F  S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI=""  W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C
-CHK10	W ! S DIR(0)="NO^1:"_CS D ^DIR
-	I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q
-	S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
-CH1E	S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
-	S TAG="CHK"
-	Q
-CHK3	;
-	S SDWLERR=""
-	S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8)
-	Q:'SDWLI!'$D(^SDWL(409.31,SDWLI))
-	I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D  Q:SDWLERR=1
-	.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)=""
-	.I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q
-	.I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q
-	.W !,"Please select a valid Institution for this record from the following list for",!
-	.D DIS
-	.S C=0,SDWLIZ=0 F  S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ=""  D
-	..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
-	..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
-	.W ! S DIR(0)="NO^1:"_C D ^DIR
-	.I $D(DUOUT)!(Y="") S SDWLERR=1 Q
-	.S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
-	.D CHE3
-	Q
-CHE3	;
-	G CHK3:Y<0
-	S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
-	S TAG="CHK"
-	Q
-CHK4	;
-	S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9)
-	Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0))
-	I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D
-	.D DIS
-	.S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
-	Q
-CHK2	;
-	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)
-	I SDWLINST'=SDWLINSN D
-	.S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
-	S TAG="CHK"
-	Q
-DIS	;display record
-	S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
-	S SSN=$$GET1^DIQ(2,NN_",",.09)
-	W !,"Record#: ",SDWLDA,"  Patient: ",NAME," (",SSN,")",!!
-	Q
-GETINS	;Get institution
-	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 GETINS
-	S SDWLINSN=+Y
-	Q
+SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03
+ ;;5.3;scheduling;**280,427**;AUG 13 1993
+EN ;
+ W !!,"Checking file 404.51 one last time.",!
+ S SDWLERR="",TEAM=0 F  S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM  D  Q:SDWLERR=1
+ . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
+ . S CODE=$$GET1^DIQ(4,INST_",",11,"I")
+ . S INCK=$$TF^XUAF4(INST)
+ . I CODE'="N"!('INCK) D
+ .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01),"    INSTITUTION: "
+ .. W $$GET1^DIQ(4,INST_",",.01)
+ .. D EDIT^SDWLCU2
+ Q:SDWLERR=1
+ ;
+ W !!,"Checking file 409.31 one last time.",!
+40931 S SDWLSS=0 F  S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS  D  Q:SDWLERR=1
+ . S SDWLINS="" F  S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS  D  Q:SDWLERR=1
+ .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
+ .. S INCK=$$TF^XUAF4(SDWLINS)
+ .. I CODE'="N"!('INCK) D
+ ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01),"    INSTITUTION: "
+ ... W $$GET1^DIQ(4,SDWLINS_",",.01)
+ ... D GETINS Q:SDWLERR=1
+ ... S SDWLSSX="" F  S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX  D  Q:SDWLERR=1
+ .... D C3^SDWLCU3
+ Q:SDWLERR=1
+40932 W !!,"Checking file 409.32 one last time.",!
+ S SDWLSC=0 F  S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC  D  Q:SDWLERR=1
+ . S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I")
+ . S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
+ . S INCK=$$TF^XUAF4(SDWLINS)
+ . I CODE'="N"!('INCK) D
+ .. W !!,"CLINIC: ",$$GET1^DIQ(409.32,SDWLSC_",",.01),"    INSTITUTION: "
+ .. W $$GET1^DIQ(4,SDWLINS_",",.01)
+ .. D GETINS Q:SDWLERR=1
+ .. K ^SDWL(409.32,"C",+SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)=""
+ .. S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN
+ K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK
+ Q:SDWLERR=1
+ W !!,"Checking file 409.3 one last time.",!
+ S SDWLERR=""
+ S SDWLDA=0,TAG="CHK" F  S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1  D  Q:SDWLERR=1
+ .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5)
+ .Q:'SDWLTY!'SDWLINST
+ .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI
+ .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG
+ W !,"Done."
+ Q
+CHK1 ;CHECK FOR INSTITUTION VALIDILITY
+ S SDWLERR=0
+ 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)=""
+ I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q
+ K ^TMP($J,"SDWLCU5",$J,"B")
+ I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q
+ I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q
+ W !,"Please select a valid Institution for this record from the following list for",!
+ D DIS
+ S C=0,SDWLI="" F  S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1  D
+ .F  S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI=""  W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C
+CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR
+ I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q
+ S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
+CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
+ S TAG="CHK"
+ Q
+CHK3 ;
+ S SDWLERR=""
+ S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8)
+ Q:'SDWLI!'$D(^SDWL(409.31,SDWLI))
+ I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D  Q:SDWLERR=1
+ .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)=""
+ .I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:""),Y=1 D CHE3 Q
+ .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q
+ .W !,"Please select a valid Institution for this record from the following list for",!
+ .D DIS
+ .S C=0,SDWLIZ=0 F  S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ=""  D
+ ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
+ ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
+ .W ! S DIR(0)="NO^1:"_C D ^DIR
+ .I $D(DUOUT)!(Y="") S SDWLERR=1 Q
+ .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0))
+ .D CHE3
+ Q
+CHE3 ;
+ G CHK3:Y<0
+ S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
+ S TAG="CHK"
+ Q
+CHK4 ;
+ S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9)
+ Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0))
+ I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D
+ .D DIS
+ .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
+ Q
+CHK2 ;
+ 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)
+ I SDWLINST'=SDWLINSN D
+ .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG")
+ S TAG="CHK"
+ Q
+DIS ;display record
+ S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E")
+ S SSN=$$GET1^DIQ(2,NN_",",.09)
+ W !,"Record#: ",SDWLDA,"  Patient: ",NAME," (",SSN,")",!!
+ Q
+GETINS ;Get institution
+ 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 GETINS
+ S SDWLINSN=+Y
+ Q
