Changeset 623 for WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXPURG1.m
r613 r623 1 ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; 5/27/08 9:26am 2 ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102**;Dec 22, 1997;Build 17 3 GET ;compile list of purgable extracts 4 K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) 5 S QFLG=1 W !!,"...one moment please" 6 S ECEX=0 F S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D 7 .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) 8 I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE 9 ASK1 ;ask for print 10 W ! 11 K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" 12 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 13 G:'Y ASK2 14 W !!,"The right margin for this report is 80.",!! 15 K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" 16 D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 17 W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 18 ASK2 ;ask for extract range 19 ; 20 ;** Check divisions for purging 21 N ECCHK,ECTMP 22 S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) 23 I 'ECCHK DO 24 .W !,"You do not have any divisions defined in your user set up and can not purge." 25 .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y 26 .K ECLOC 27 ; 28 I 'ECCHK G DONE ;** (essentially) QUIT out of middle 29 ; 30 W !,"You will not be able to select an extract that is not from your division.",! 31 S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) 32 S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" 33 S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)." 34 W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 35 S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) 36 D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET 37 D DIVCHK(.ECLOC,.ECTMP) 38 I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET 39 ASK3 W !!,"I will purge the following extract(s):" 40 S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D 41 .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) 42 .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") 43 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 44 S DIR("?",1)=" Enter:" 45 S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," 46 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 47 S DIR("?")=" ""^"" to exit option." 48 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 49 I 'Y G GET 50 ; at this point, the local array ECLOC( is passed back to ^ECXPURG 51 G DONE 52 QUIT ; 53 I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 54 .S SS=22-$Y F JJ=1:1:SS W ! 55 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" 56 DONE K ^TMP("ECXPURG",$J),ZTSK Q 57 PRT ;print list of extracts 58 S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR 59 S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D 60 .S ECEX=0 F S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX Q:QFLG I $D(^ECX(727,ECEX,0)) S EC=^(0) D 61 ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") 62 ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") 63 ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") 64 ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" 65 ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") 66 ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D 67 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 68 ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 69 ..D:$Y+3>IOSL HDR Q:QFLG 70 ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV 71 G QUIT 72 HDR ;HEADER 73 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 74 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 75 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! 76 W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN 77 Q 78 DATES ;ask for date range for purge of holding files 79 K HI,LO,ECBDT,ECEDT 80 I ECY="I" D 81 .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q 82 .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) 83 I ECY="U" D 84 .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q 85 .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) 86 I ECY="V" D 87 .I '$O(^VBEC(6002.03,0)) W !!,"You have no data in the VBECS holding file (file #6002.03) to purge." Q 88 .S LO=$O(^VBEC(6002.03,"C",0)),HI=$O(^VBEC(6002.03,"C"," "),-1) 89 Q:$G(LO)="" 90 W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">." 91 W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q 92 S ECBDT=+Y 93 K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q 94 S ECEDT=+Y 95 ASK4 ; ask to confirm date range 96 W !!,"I will purge the ",$S(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">." 97 W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" 98 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 99 S DIR("?",1)=" Enter:" 100 S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," 101 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 102 S DIR("?")=" ""^"" to exit option." 103 D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 104 I 'Y G DATES 105 ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG 106 Q 107 ; 108 DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. 109 N ECLPDA 110 S ECLPDA=0 111 F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO 112 .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) 113 Q 114 CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging 115 N LOOPDA,YYYMMDD 116 S LOOPDA=0 117 F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D 118 .I ^ECX(727,LOOPDA,"HEAD")="CLI" D 119 ..S DA(1)=1 120 ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) 121 ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D 122 ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" 123 ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) 124 Q 1 ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ; [ 12/05/96 11:58 AM ] 2 ;;3.0;DSS EXTRACTS;**2,9,8,24,49**;Dec 22, 1997 3 GET ;compile list of purgable extracts 4 K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J) 5 S QFLG=1 W !!,"...one moment please" 6 S ECEX=0 F S ECEX=$O(^ECX(727,ECEX)) Q:'ECEX I '$G(^ECX(727,ECEX,"PURG")),$D(^ECX(727,ECEX,0)) S EC=^(0) D 7 .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5) 8 I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be purged at this time." G DONE 9 ASK1 ;ask for print 10 W ! 11 K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be purged",DIR("B")="NO" 12 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 13 G:'Y ASK2 14 W !!,"The right margin for this report is 80.",!! 15 K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")="" 16 D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Purgable Extracts",.ZTSAVE) I 'POP G ASK2 17 W !,"NO DEVICE SELECTED OR REPORT PRINTED!!" 18 ASK2 ;ask for extract range 19 ; 20 ;** Check divisions for purging 21 N ECCHK,ECTMP 22 S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ) 23 I 'ECCHK DO 24 .W !,"You do not have any divisions defined in your user set up and can not purge." 25 .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y 26 .K ECLOC 27 ; 28 I 'ECCHK G DONE ;** (essentially) QUIT out of middle 29 ; 30 W !,"You will not be able to select an extract that is not from your division.",! 31 S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1) 32 S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be purged" 33 S DIR("?",1)="Choose the number(s) of the extract(s) you wish to purge,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)." 34 W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 35 S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ) 36 D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET 37 D DIVCHK(.ECLOC,.ECTMP) 38 I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET 39 ASK3 W !!,"I will purge the following extract(s):" 40 S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D 41 .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U) 42 .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0") 43 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 44 S DIR("?",1)=" Enter:" 45 S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed," 46 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 47 S DIR("?")=" ""^"" to exit option." 48 D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE 49 I 'Y G GET 50 ; at this point, the local array ECLOC( is passed back to ^ECXPURG 51 G DONE 52 QUIT ; 53 I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR 54 .S SS=22-$Y F JJ=1:1:SS W ! 55 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" 56 DONE K ^TMP("ECXPURG",$J),ZTSK Q 57 PRT ;print list of extracts 58 S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR 59 S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D 60 .S ECEX=0 F S ECEX=$O(^TMP("ECXPURG",$J,ECTYP,ECEX)) Q:'ECEX Q:QFLG I $D(^ECX(727,ECEX,0)) S EC=^(0) D 61 ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D") 62 ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0") 63 ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0") 64 ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete" 65 ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D") 66 ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D 67 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" 68 ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC 69 ..D:$Y+3>IOSL HDR Q:QFLG 70 ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV 71 G QUIT 72 HDR ;HEADER 73 I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W ! 74 I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q 75 S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"PURGABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,! 76 W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN 77 Q 78 DATES ;ask for date range for purge of holding files 79 K HI,LO,ECBDT,ECEDT 80 I ECY="I" D 81 .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q 82 .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1) 83 I ECY="U" D 84 .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q 85 .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1) 86 Q:$G(LO)="" 87 W @IOF,!!,"This file currently holds ",$S(ECY="I":"IVP",1:"UDP")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">." 88 W ! K DIR S DIR(0)="DA^"_LO_":"_HI_":EPX",DIR("A")="Beginning date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO Q 89 S ECBDT=+Y 90 K DIR S DIR(0)="DA^"_ECBDT_":"_HI_":EPX",DIR("A")="Ending date for purge: " D ^DIR K DIR I $D(DIRUT) K HI,LO,ECBDT Q 91 S ECEDT=+Y 92 ASK4 ; ask to confirm date range 93 W !!,"I will purge the ",$S(ECY="I":"IVP",1:"UDP")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">." 94 W $C(7),$C(7),!!?3,"** REMEMBER - Once this data is purged it CANNOT be recreated. **" 95 W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO" 96 S DIR("?",1)=" Enter:" 97 S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed," 98 S DIR("?",3)=" ""NO"" if you would like to make a different selection, or" 99 S DIR("?")=" ""^"" to exit option." 100 D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q 101 I 'Y G DATES 102 ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG 103 Q 104 ; 105 DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div. 106 N ECLPDA 107 S ECLPDA=0 108 F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO 109 .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA) 110 Q 111 CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to purging 112 N LOOPDA,YYYMMDD 113 S LOOPDA=0 114 F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D 115 .I ^ECX(727,LOOPDA,"HEAD")="CLI" D 116 ..S DA(1)=1 117 ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4) 118 ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D 119 ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Purge anyway",DIR("B")="NO" 120 ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA) 121 Q
Note:
See TracChangeset
for help on using the changeset viewer.
