SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03
;;5.3;scheduling;**280,427,491,539**;AUG 13 1993;Build 24
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
.I $P($G(^SDWL(409.3,SDWLDA,0)),U,17)'="O" Q ; sd/539 ONLY OPEN ENTRIES
.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 entries 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)
I $P($G(^SDWL(409.3,SDWLDA,0)),U,17)'="O" Q ; sd/539 ONLY OPEN ewl entries
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDWLCU5 6978 printed Apr 09, 2024@21:46:22 Page 2
SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03
+1 ;;5.3;scheduling;**280,427,491,539**;AUG 13 1993;Build 24
EN ;
+1 WRITE !!,"Checking file 404.51 one last time.",!
+2 SET SDWLERR=""
SET TEAM=0
FOR
SET TEAM=$ORDER(^SCTM(404.51,TEAM))
if 'TEAM
QUIT
Begin DoDot:1
+3 SET INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I")
+4 SET CODE=$$GET1^DIQ(4,INST_",",11,"I")
+5 SET INCK=$$TF^XUAF4(INST)
+6 IF CODE'="N"!('INCK)
Begin DoDot:2
+7 WRITE !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: "
+8 WRITE $$GET1^DIQ(4,INST_",",.01)
+9 DO EDIT^SDWLCU2
End DoDot:2
End DoDot:1
if SDWLERR=1
QUIT
+10 if SDWLERR=1
QUIT
+11 ;
+12 WRITE !!,"Checking file 409.31 one last time.",!
40931 SET SDWLSS=0
FOR
SET SDWLSS=$ORDER(^SDWL(409.31,SDWLSS))
if 'SDWLSS
QUIT
Begin DoDot:1
+1 SET SDWLINS=""
FOR
SET SDWLINS=$ORDER(^SDWL(409.31,SDWLSS,"I","B",SDWLINS))
if 'SDWLINS
QUIT
Begin DoDot:2
+2 SET CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I")
+3 SET INCK=$$TF^XUAF4(SDWLINS)
+4 IF CODE'="N"!('INCK)
Begin DoDot:3
+5 WRITE !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: "
+6 WRITE $$GET1^DIQ(4,SDWLINS_",",.01)
+7 DO GETINS
if SDWLERR=1
QUIT
+8 SET SDWLSSX=""
FOR
SET SDWLSSX=$ORDER(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX))
if 'SDWLSSX
QUIT
Begin DoDot:4
+9 DO C3^SDWLCU3
End DoDot:4
if SDWLERR=1
QUIT
End DoDot:3
End DoDot:2
if SDWLERR=1
QUIT
End DoDot:1
if SDWLERR=1
QUIT
+10 if SDWLERR=1
QUIT
40932 WRITE !!,"Checking file 409.32 one last time.",!
+1 NEW INERROR
SET INERROR=""
SET SDWLSC=0
FOR
SET SDWLSC=$ORDER(^SDWL(409.32,SDWLSC))
if 'SDWLSC
QUIT
DO UPDINS(SDWLSC,.INERROR)
+2 if INERROR=1
QUIT
+3 NEW DIK
SET DIK="^SDWL(409.32,"
DO IXALL^DIK
+4 WRITE !!,"Checking file 409.3 one last time.",!
+5 SET SDWLERR=""
+6 SET SDWLDA=0
SET TAG="CHK"
FOR
SET SDWLDA=$ORDER(^SDWL(409.3,SDWLDA))
if SDWLDA<1
QUIT
Begin DoDot:1
+7 ; sd/539 ONLY OPEN ENTRIES
IF $PIECE($GET(^SDWL(409.3,SDWLDA,0)),U,17)'="O"
QUIT
+8 SET X=$GET(^SDWL(409.3,SDWLDA,0))
SET SDWLINST=$PIECE(X,"^",3)
SET SDWLTY=$PIECE(X,"^",5)
+9 if 'SDWLTY!'SDWLINST
QUIT
+10 SET SDWLI=$PIECE(X,"^",SDWLTY+5)
if 'SDWLI
QUIT
+11 SET TAG="CHK"
SET TAG=TAG_SDWLTY
SET C=0
KILL ^TMP($JOB,"SDWLCU5",$JOB)
DO @TAG
End DoDot:1
if SDWLERR=1
QUIT
+12 WRITE !,"Done."
+13 QUIT
UPDINS(SDWLSC,INERROR) ; update 409.32 and the related entries in 409.3
+1 ; current set up in 409.32
NEW SDWLINS
SET SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I")
+2 ;check set up in file 44
+3 ;get clinic
+4 NEW CL,CLN
SET CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I")
SET CLN=$$GET1^DIQ(44,CL_",",.01)
+5 NEW STR,SDWMES
SET SDWMES=""
SET STR=$$CLIN^SDWLPE(CL)
+6 SET SDWMES=SDWMES_$PIECE(STR,U,6)
+7 IF $PIECE(STR,U,5)="L"
SET SDWMES=SDWMES_" - Local Institution assigned to clinic. "
+8 IF SDWMES'=""
Begin DoDot:1
+9 WRITE !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **"
+10 WRITE !!,SDWMES
+11 WRITE !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY."
+12 WRITE !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP."
+13 if INERROR=""
SET INERROR=1
QUIT
End DoDot:1
QUIT
+14 IF +STR'=SDWLINS
WRITE !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up."
Begin DoDot:1
+15 WRITE !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99)
+16 WRITE !,"Clinic INSTITUTION: ",$PIECE(STR,U,3)_" - "_$PIECE(STR,U,2)
+17 WRITE !!,"EWL set up will be updated with the Clinic from the Hospital Location file,"
+18 WRITE !,"and the related open EWL entries will be updated as well."
+19 NEW DIE,DR,DA
SET DR=".02////^S X=+STR"
SET DIE="^SDWL(409.32,"
SET DA=SDWLSC
+20 LOCK +^SDWL(409.32,DA):0
IF '$TEST
WRITE !?5,"Another user is editing this entry. try later."
QUIT
+21 DO ^DIE
LOCK -^SDWL(409.32,DA)
+22 ;loop to update EWL entries in FILE 409.3 if any
+23 NEW SCL,DA,DR,CNT
SET SCL=""
SET CNT=0
FOR
SET SCL=$ORDER(^SDWL(409.3,"SC",CL,SCL))
if SCL'>0
QUIT
Begin DoDot:2
+24 IF '$DATA(^SDWL(409.3,SCL,0))
KILL ^SDWL(409.3,"SC",CL,SCL)
QUIT
+25 SET DR="2////^S X=+STR"
SET DIE="^SDWL(409.3,"
SET DA=SCL
+26 LOCK +^SDWL(409.3,SCL):0
IF '$TEST
WRITE !?5,"Another user is editing this entry. try later."
QUIT
+27 DO ^DIE
LOCK -^SDWL(409.3,SCL)
SET CNT=CNT+1
End DoDot:2
+28 IF CNT>0
WRITE !,CNT_" EWL entries for clinic "_CLN_" updated."
End DoDot:1
+29 NEW DA
IF $$GET1^DIQ(409.32,SDWLSC_",",3,"I")=""
IF $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0
Begin DoDot:1
+30 SET DA=SDWLSC
LOCK +^SDWL(409.32,SDWLSC):0
IF '$TEST
WRITE !?5,"Another user is editing this entry. try later."
QUIT
+31 ;enter activation date and user
SET DR="1////^S X=DT;2////^S X=DUZ"
SET DIE="^SDWL(409.32,"
+32 DO ^DIE
LOCK -^SDWL(409.32,SDWLSC)
+33 WRITE !,"EWL Clinic entry for "_CLN_" updated with today's activation date."
End DoDot:1
+34 QUIT
CHK1 ;CHECK FOR INSTITUTION VALIDILITY
+1 SET SDWLERR=0
+2 IF SDWLTY=1
SET SDWLI=0
FOR
SET SDWLI=$ORDER(^SCTM(404.51,"AINST",SDWLI))
if SDWLI=""
QUIT
IF $DATA(^DIC(4,SDWLI))
SET C=C+1
SET ^TMP($JOB,"SDWLCU5",$JOB,C,SDWLI)=""
SET ^TMP($JOB,"SDWLCU5",$JOB,"B",SDWLI)=""
+3 IF $DATA(^TMP($JOB,"SDWLCU5",$JOB,"B",SDWLINST))
QUIT
+4 KILL ^TMP($JOB,"SDWLCU5",$JOB,"B")
+5 IF 'C
SET SDWLINSN=$SELECT($DATA(DUZ(2)):DUZ(2),1:"")
DO CH1E
QUIT
+6 IF C=1
SET SDWLINSN=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,C,0))
DO CH1E
QUIT
+7 WRITE !,"Please select a valid Institution for this record from the following list for",!
+8 DO DIS
+9 SET C=0
SET SDWLI=""
FOR
SET C=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,C))
if C<1
QUIT
Begin DoDot:1
+10 FOR
SET SDWLI=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,C,SDWLI))
if SDWLI=""
QUIT
WRITE !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01)
SET CS=C
End DoDot:1
CHK10 WRITE !
SET DIR(0)="NO^1:"_CS
DO ^DIR
+1 IF Y<1!($DATA(DUOUT))
WRITE !,"Response Required."
SET SDWLERR=1
QUIT
+2 SET SDWLINSN=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,+Y,0))
CH1E SET SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN
DO UPDATE^DIE("","SDWLINS","SDWLMSG")
+1 SET TAG="CHK"
+2 QUIT
CHK3 ;
+1 SET SDWLERR=""
+2 SET SDWLI=$PIECE(^SDWL(409.3,SDWLDA,0),U,8)
+3 ; sd/539 ONLY OPEN ewl entries
IF $PIECE($GET(^SDWL(409.3,SDWLDA,0)),U,17)'="O"
QUIT
+4 if 'SDWLI!'$DATA(^SDWL(409.31,SDWLI))
QUIT
+5 IF '$DATA(^SDWL(409.31,SDWLI,"I","B",SDWLINST))
Begin DoDot:1
+6 SET SDWLIX=""
SET C=0
FOR
SET SDWLIX=$ORDER(^SDWL(409.31,SDWLI,"I","B",SDWLIX))
if SDWLIX=""
QUIT
SET C=C+1
SET ^TMP($JOB,"SDWLCU5",$JOB,C,SDWLIX)=""
SET ^TMP($JOB,"SDWLCU5",$JOB,"B",SDWLIX)=""
+7 IF 'C
NEW SITE
SET SITE=+$$SITE^VASITE(,)
SET SDWLINSN=$SELECT(SITE>0:SITE,1:"")
SET Y=1
DO CHE3
QUIT
+8 IF C=1
SET SDWLINSN=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,C,0))
SET Y=1
DO CHE3
QUIT
+9 WRITE !,"Please select a valid Institution for this record from the following list for",!
+10 DO DIS
+11 SET C=0
SET SDWLIZ=0
FOR
SET SDWLIZ=$ORDER(^SDWL(409.31,SDWLI,"I","B",SDWLIZ))
if SDWLIZ=""
QUIT
Begin DoDot:2
+12 if $$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ))
QUIT
+13 SET C=C+1
WRITE !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01)
End DoDot:2
+14 WRITE !
SET DIR(0)="NO^1:"_C
DO ^DIR
+15 IF $DATA(DUOUT)!(Y="")
SET SDWLERR=1
QUIT
+16 SET SDWLINSN=$ORDER(^TMP($JOB,"SDWLCU5",$JOB,+Y,0))
+17 DO CHE3
End DoDot:1
if SDWLERR=1
QUIT
+18 QUIT
CHE3 ;
+1 if Y<0
GOTO CHK3
+2 SET SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN
DO UPDATE^DIE("","SDWLINS","SDWLMSG")
+3 SET TAG="CHK"
+4 QUIT
CHK4 ;
+1 SET SDWLI=$PIECE(^SDWL(409.3,SDWLDA,0),U,9)
+2 if 'SDWLI!'$DATA(^SDWL(409.32,SDWLI,0))
QUIT
+3 IF $PIECE(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST
Begin DoDot:1
+4 DO DIS
+5 SET SDWLINSN=$PIECE(^SDWL(409.32,SDWLI,0),U,6)
SET SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN
DO UPDATE^DIE("","SDWLINS","SDWLMSG")
End DoDot:1
+6 QUIT
CHK2 ;
+1 SET SDWLPO=$PIECE($GET(^SDWL(409.3,SDWLDA,0)),U,7)
SET SDWLTM=$PIECE($GET(^SCTM(404.57,SDWLPO,0)),U,2)
SET SDWLINSN=$PIECE($GET(^SCTM(404.51,SDWLTM,0)),U,7)
+2 IF SDWLINST'=SDWLINSN
Begin DoDot:1
+3 SET SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN
DO UPDATE^DIE("","SDWLINS","SDWLMSG")
End DoDot:1
+4 SET TAG="CHK"
+5 QUIT
DIS ;display record
+1 SET NN=$PIECE($GET(^SDWL(409.3,SDWLDA,0)),"^")
SET NAME=$$GET1^DIQ(2,NN_",",.01,"E")
+2 SET SSN=$$GET1^DIQ(2,NN_",",.09)
+3 WRITE !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!!
+4 QUIT
GETINS ;Get institution
+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 GETINS
+6 SET SDWLINSN=+Y
+7 QUIT
