Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m
r613 r623 1 SDWLCU5 ;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 3 EN ; 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.",! 16 40931 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 27 40932 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 40 UPDINS(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 75 CHK1 ;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 86 CHK10 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)) 89 CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 90 S TAG="CHK" 91 Q 92 CHK3 ; 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 110 CHE3 ; 111 G CHK3:Y<0 112 S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 113 S TAG="CHK" 114 Q 115 CHK4 ; 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 122 CHK2 ; 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 128 DIS ;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 133 GETINS ;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 1 SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 2 ;;5.3;scheduling;**280,427**;AUG 13 1993 3 EN ; 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.",! 16 40931 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 27 40932 W !!,"Checking file 409.32 one last time.",! 28 S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D Q:SDWLERR=1 29 . S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") 30 . S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") 31 . S INCK=$$TF^XUAF4(SDWLINS) 32 . I CODE'="N"!('INCK) D 33 .. W !!,"CLINIC: ",$$GET1^DIQ(409.32,SDWLSC_",",.01)," INSTITUTION: " 34 .. W $$GET1^DIQ(4,SDWLINS_",",.01) 35 .. D GETINS Q:SDWLERR=1 36 .. K ^SDWL(409.32,"C",+SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)="" 37 .. S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN 38 K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK 39 Q:SDWLERR=1 40 W !!,"Checking file 409.3 one last time.",! 41 S SDWLERR="" 42 S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 43 .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) 44 .Q:'SDWLTY!'SDWLINST 45 .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI 46 .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG 47 W !,"Done." 48 Q 49 CHK1 ;CHECK FOR INSTITUTION VALIDILITY 50 S SDWLERR=0 51 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)="" 52 I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q 53 K ^TMP($J,"SDWLCU5",$J,"B") 54 I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q 55 I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q 56 W !,"Please select a valid Institution for this record from the following list for",! 57 D DIS 58 S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D 59 .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C 60 CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR 61 I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q 62 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) 63 CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 64 S TAG="CHK" 65 Q 66 CHK3 ; 67 S SDWLERR="" 68 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) 69 Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) 70 I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 71 .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)="" 72 .I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:""),Y=1 D CHE3 Q 73 .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q 74 .W !,"Please select a valid Institution for this record from the following list for",! 75 .D DIS 76 .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D 77 ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) 78 ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) 79 .W ! S DIR(0)="NO^1:"_C D ^DIR 80 .I $D(DUOUT)!(Y="") S SDWLERR=1 Q 81 .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) 82 .D CHE3 83 Q 84 CHE3 ; 85 G CHK3:Y<0 86 S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 87 S TAG="CHK" 88 Q 89 CHK4 ; 90 S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) 91 Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) 92 I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D 93 .D DIS 94 .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 95 Q 96 CHK2 ; 97 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) 98 I SDWLINST'=SDWLINSN D 99 .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") 100 S TAG="CHK" 101 Q 102 DIS ;display record 103 S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") 104 S SSN=$$GET1^DIQ(2,NN_",",.09) 105 W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! 106 Q 107 GETINS ;Get institution 108 N DIR 109 S DIR("A")="Select Institution: " 110 S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR 111 I X["^" S SDWLERR=1 Q 112 I Y<1 W *7,"Invalid Entry" G GETINS 113 S SDWLINSN=+Y 114 Q
Note:
See TracChangeset
for help on using the changeset viewer.
