- ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ;8/20/13 11:04
- ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102,112,144**;Dec 22, 1997;Build 9
- GET ;compile list of deletable extracts 144
- K HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$J)
- S QFLG=1 W !!,"...one moment please"
- 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
- .S ^TMP("ECXPURG",$J,$P(EC,U,3),ECEX)="",ECLOC(ECEX)=$P(EC,U,3)_U_$P(EC,U,4,5)
- I '$D(^TMP("ECXPURG",$J)) W !!,"There are no extracts that can be deleted at this time." G DONE ;144
- ASK1 ;ask for print
- W !
- K DIR S DIR(0)="Y",DIR("A")="Do you want to print a list of extracts that can be deleted",DIR("B")="NO"
- D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
- G:'Y ASK2
- W !!,"The right margin for this report is 80.",!!
- K ZTSAVE S ZTSAVE("^TMP(""ECXPURG"",$J,")=""
- D EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Deletable Extracts",.ZTSAVE) I 'POP G ASK2
- W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
- ASK2 ;ask for extract range
- ;
- ;** Check divisions for deleting
- N ECCHK,ECTMP,JZ ;144
- S ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
- I 'ECCHK DO
- .W !,"You do not have any divisions defined in your user set up and can not delete."
- .S DIR(0)="FAO^1:1",DIR("A")="Hit Return to continue." D ^DIR K DIR,X,Y
- .K ECLOC
- ;
- I 'ECCHK G DONE ;** (essentially) QUIT out of middle
- ;
- W !,"You will not be able to select an extract that is not from your division.",!
- S LO=$O(ECLOC(0)),HI=$O(ECLOC(" "),-1)
- S DIR(0)="L^"_LO_":"_HI_"",DIR("A")="Select extracts to be deleted"
- S DIR("?",1)="Choose the number(s) of the extract(s) you wish to delete,",DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)."
- W ! D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
- S JJ=0,Y=","_Y F S JJ=$O(ECLOC(JJ)) Q:'JJ S JZ=","_JJ_"," I Y'[JZ K ECLOC(JJ)
- I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET ;144 Give message if no valid selection made
- D CBOCCHK(.ECLOC) I '$D(ECLOC) G GET
- D DIVCHK(.ECLOC,.ECTMP)
- I '$D(ECLOC) W !!,"You have not chosen a valid extract number. Try again." G GET
- ASK3 W !!,"I will delete the following extract(s):"
- S JJ=0 F S JJ=$O(ECLOC(JJ)) Q:'JJ D
- .W !?5,"#",JJ," - ",$P(ECLOC(JJ),U)
- .W ?47,$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TR($$FMTE^XLFDT($P(ECLOC(JJ),U,3),"5DF")," ","0")
- W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
- S DIR("?",1)=" Enter:"
- S DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed,"
- S DIR("?",3)=" ""NO"" if you would like to make a different selection, or"
- S DIR("?")=" ""^"" to exit option."
- D ^DIR K DIR I $D(DIRUT) K ECLOC G DONE
- I 'Y G GET
- ; at this point, the local array ECLOC( is passed back to ^ECXPURG
- G DONE
- QUIT ;
- I $E(IOST)="C"&('QFLG) S DIR(0)="E" D D ^DIR K DIR
- .S SS=22-$Y F JJ=1:1:SS W !
- W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- DONE K ^TMP("ECXPURG",$J),ZTSK Q
- PRT ;print list of extracts
- S (PG,QFLG)=0,$P(LN,"-",81)="" D NOW^%DTC S Y=$E(%,1,12) X ^DD("DD") S HDT=Y D HDR
- S ECTYP="" F S ECTYP=$O(^TMP("ECXPURG",$J,ECTYP)) Q:ECTYP="" Q:QFLG D:$Y+4>IOSL HDR Q:QFLG W !!,ECTYP D
- .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
- ..S ECDT=$$FMTE^XLFDT($P(EC,U,2),"D")
- ..S ECFR=$TR($$FMTE^XLFDT($P(EC,U,4),"5DF")," ","0")
- ..S ECTO=$TR($$FMTE^XLFDT($P(EC,U,5),"5DF")," ","0")
- ..S ECRC=$P(EC,U,6) S:ECRC="" ECRC="Incomplete"
- ..S ECTRN=$$FMTE^XLFDT($G(^ECX(727,ECEX,"TR")),"D")
- ..S ECXDIV=$P($G(^ECX(727,ECEX,"DIV")),U,1) I ECXDIV D
- ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"
- ...D EN^DIQ1 S ECXDIV=$G(ECXDIC(4,DA,99,"I")) K DIC,DIQ,DA,DR,ECXDIC
- ..D:$Y+3>IOSL HDR Q:QFLG
- ..W !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$J(ECRC,9),?60,ECTRN,?75,ECXDIV
- G QUIT
- HDR ;HEADER
- I $E(IOST)="C" S SS=22-$Y F JJ=1:1:SS W !
- I $E(IOST)="C",PG>0 S DIR(0)="E" W ! D ^DIR K DIR I 'Y S QFLG=1 Q
- S PG=PG+1 W:$Y!($E(IOST)="C") @IOF W !,"DELETABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,!
- W !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN
- Q
- DATES ;ask for date range for purge of holding files
- K HI,LO,ECBDT,ECEDT
- I ECY="I" D
- .I '$O(^ECX(728.113,0)) W !!,"You have no data in the IVP holding file (file #728.113) to purge." Q
- .S LO=$O(^ECX(728.113,"A",0)),HI=$O(^ECX(728.113,"A"," "),-1)
- I ECY="U" D
- .I '$O(^ECX(728.904,0)) W !!,"You have no data in the UDP holding file (file #728.904) to purge." Q
- .S LO=$O(^ECX(728.904,"A",0)),HI=$O(^ECX(728.904,"A"," "),-1)
- I ECY="V" D
- .I '$O(^VBEC(6002.03,0)) W !!,"You have no data in the VBECS holding file (file #6002.03) to purge." Q
- .S LO=$O(^VBEC(6002.03,"C",0)),HI=$O(^VBEC(6002.03,"C"," "),-1)
- Q:$G(LO)=""
- 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"),">."
- 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
- S ECBDT=+Y
- 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
- S ECEDT=+Y
- ASK4 ; ask to confirm date range
- 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"),">."
- W !! K DIR S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
- S DIR("?",1)=" Enter:"
- S DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed,"
- S DIR("?",3)=" ""NO"" if you would like to make a different selection, or"
- S DIR("?")=" ""^"" to exit option."
- D ^DIR K DIR I $D(DIRUT) K ECBDT,ECEDT Q
- I 'Y G DATES
- ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG
- Q
- ;
- DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div.
- N ECLPDA
- S ECLPDA=0
- F S ECLPDA=$O(ECLOC(ECLPDA)) Q:(+ECLPDA=0) DO
- .I '$D(ECTMP($P(^ECX(727,ECLPDA,"DIV"),U,1))) KILL ECLOC(ECLPDA)
- Q
- CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to deleting
- N LOOPDA,YYYMMDD
- S LOOPDA=0
- F S LOOPDA=$O(ECLOC(LOOPDA)) Q:(+LOOPDA=0) D
- .I ^ECX(727,LOOPDA,"HEAD")="CLI" D
- ..S DA(1)=1
- ..S YYYMMDD=$P(^ECX(727,LOOPDA,0),U,4)
- ..I YYYMMDD>3030930 I '$D(^ECX(728,DA(1),"CBOC","B",LOOPDA)) D
- ...K DIR S DIR(0)="Y",DIR("A")="The CBOC Activity Report has not been viewed. Delete anyway",DIR("B")="NO" ;144
- ...D ^DIR K DIR I 'Y K ECLOC(LOOPDA)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXPURG1 6597 printed Mar 13, 2025@20:58:19 Page 2
- ECXPURG1 ;BIR/CML-Purge of DSS Extract Files (CONTINUED) ;8/20/13 11:04
- +1 ;;3.0;DSS EXTRACTS;**2,9,8,24,49,102,112,144**;Dec 22, 1997;Build 9
- GET ;compile list of deletable extracts 144
- +1 KILL HI,LO,ECBDT,ECEDT,ECLOC,^TMP("ECXPURG",$JOB)
- +2 SET QFLG=1
- WRITE !!,"...one moment please"
- +3 SET ECEX=0
- FOR
- SET ECEX=$ORDER(^ECX(727,ECEX))
- if 'ECEX
- QUIT
- IF '$GET(^ECX(727,ECEX,"PURG"))
- IF $DATA(^ECX(727,ECEX,0))
- SET EC=^(0)
- Begin DoDot:1
- +4 SET ^TMP("ECXPURG",$JOB,$PIECE(EC,U,3),ECEX)=""
- SET ECLOC(ECEX)=$PIECE(EC,U,3)_U_$PIECE(EC,U,4,5)
- End DoDot:1
- +5 ;144
- IF '$DATA(^TMP("ECXPURG",$JOB))
- WRITE !!,"There are no extracts that can be deleted at this time."
- GOTO DONE
- ASK1 ;ask for print
- +1 WRITE !
- +2 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to print a list of extracts that can be deleted"
- SET DIR("B")="NO"
- +3 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL ECLOC
- GOTO DONE
- +4 if 'Y
- GOTO ASK2
- +5 WRITE !!,"The right margin for this report is 80.",!!
- +6 KILL ZTSAVE
- SET ZTSAVE("^TMP(""ECXPURG"",$J,")=""
- +7 DO EN^XUTMDEVQ("PRT^ECXPURG1","DSS - Print Deletable Extracts",.ZTSAVE)
- IF 'POP
- GOTO ASK2
- +8 WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
- ASK2 ;ask for extract range
- +1 ;
- +2 ;** Check divisions for deleting
- +3 ;144
- NEW ECCHK,ECTMP,JZ
- +4 SET ECCHK=$$DIV4^XUSER(.ECTMP,DUZ)
- +5 IF 'ECCHK
- Begin DoDot:1
- +6 WRITE !,"You do not have any divisions defined in your user set up and can not delete."
- +7 SET DIR(0)="FAO^1:1"
- SET DIR("A")="Hit Return to continue."
- DO ^DIR
- KILL DIR,X,Y
- +8 KILL ECLOC
- End DoDot:1
- +9 ;
- +10 ;** (essentially) QUIT out of middle
- IF 'ECCHK
- GOTO DONE
- +11 ;
- +12 WRITE !,"You will not be able to select an extract that is not from your division.",!
- +13 SET LO=$ORDER(ECLOC(0))
- SET HI=$ORDER(ECLOC(" "),-1)
- +14 SET DIR(0)="L^"_LO_":"_HI_""
- SET DIR("A")="Select extracts to be deleted"
- +15 SET DIR("?",1)="Choose the number(s) of the extract(s) you wish to delete,"
- SET DIR("?")="(e.g. 1-3,17,20 to choose 1 thru 3, 17, and 20)."
- +16 WRITE !
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL ECLOC
- GOTO DONE
- +17 SET JJ=0
- SET Y=","_Y
- FOR
- SET JJ=$ORDER(ECLOC(JJ))
- if 'JJ
- QUIT
- SET JZ=","_JJ_","
- IF Y'[JZ
- KILL ECLOC(JJ)
- +18 ;144 Give message if no valid selection made
- IF '$DATA(ECLOC)
- WRITE !!,"You have not chosen a valid extract number. Try again."
- GOTO GET
- +19 DO CBOCCHK(.ECLOC)
- IF '$DATA(ECLOC)
- GOTO GET
- +20 DO DIVCHK(.ECLOC,.ECTMP)
- +21 IF '$DATA(ECLOC)
- WRITE !!,"You have not chosen a valid extract number. Try again."
- GOTO GET
- ASK3 WRITE !!,"I will delete the following extract(s):"
- +1 SET JJ=0
- FOR
- SET JJ=$ORDER(ECLOC(JJ))
- if 'JJ
- QUIT
- Begin DoDot:1
- +2 WRITE !?5,"#",JJ," - ",$PIECE(ECLOC(JJ),U)
- +3 WRITE ?47,$TRANSLATE($$FMTE^XLFDT($PIECE(ECLOC(JJ),U,2),"5DF")," ","0")," to ",$TRANSLATE($$FMTE^XLFDT($PIECE(ECLOC(JJ),U,3),"5DF")," ","0")
- End DoDot:1
- +4 WRITE !!
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Is this OK"
- SET DIR("B")="NO"
- +5 SET DIR("?",1)=" Enter:"
- +6 SET DIR("?",2)=" ""YES"" if you agree with this list and would like to proceed,"
- +7 SET DIR("?",3)=" ""NO"" if you would like to make a different selection, or"
- +8 SET DIR("?")=" ""^"" to exit option."
- +9 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL ECLOC
- GOTO DONE
- +10 IF 'Y
- GOTO GET
- +11 ; at this point, the local array ECLOC( is passed back to ^ECXPURG
- +12 GOTO DONE
- QUIT ;
- +1 IF $EXTRACT(IOST)="C"&('QFLG)
- SET DIR(0)="E"
- Begin DoDot:1
- +2 SET SS=22-$Y
- FOR JJ=1:1:SS
- WRITE !
- End DoDot:1
- DO ^DIR
- KILL DIR
- +3 if $EXTRACT(IOST)'="C"
- WRITE @IOF
- DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- DONE KILL ^TMP("ECXPURG",$JOB),ZTSK
- QUIT
- PRT ;print list of extracts
- +1 SET (PG,QFLG)=0
- SET $PIECE(LN,"-",81)=""
- DO NOW^%DTC
- SET Y=$EXTRACT(%,1,12)
- XECUTE ^DD("DD")
- SET HDT=Y
- DO HDR
- +2 SET ECTYP=""
- FOR
- SET ECTYP=$ORDER(^TMP("ECXPURG",$JOB,ECTYP))
- if ECTYP=""
- QUIT
- if QFLG
- QUIT
- if $Y+4>IOSL
- DO HDR
- if QFLG
- QUIT
- WRITE !!,ECTYP
- Begin DoDot:1
- +3 SET ECEX=0
- FOR
- SET ECEX=$ORDER(^TMP("ECXPURG",$JOB,ECTYP,ECEX))
- if 'ECEX
- QUIT
- if QFLG
- QUIT
- IF $DATA(^ECX(727,ECEX,0))
- SET EC=^(0)
- Begin DoDot:2
- +4 SET ECDT=$$FMTE^XLFDT($PIECE(EC,U,2),"D")
- +5 SET ECFR=$TRANSLATE($$FMTE^XLFDT($PIECE(EC,U,4),"5DF")," ","0")
- +6 SET ECTO=$TRANSLATE($$FMTE^XLFDT($PIECE(EC,U,5),"5DF")," ","0")
- +7 SET ECRC=$PIECE(EC,U,6)
- if ECRC=""
- SET ECRC="Incomplete"
- +8 SET ECTRN=$$FMTE^XLFDT($GET(^ECX(727,ECEX,"TR")),"D")
- +9 SET ECXDIV=$PIECE($GET(^ECX(727,ECEX,"DIV")),U,1)
- IF ECXDIV
- Begin DoDot:3
- +10 KILL ECXDIC
- SET DA=ECXDIV
- SET DIC="^DIC(4,"
- SET DIQ(0)="I"
- SET DIQ="ECXDIC"
- SET DR=".01;99"
- +11 DO EN^DIQ1
- SET ECXDIV=$GET(ECXDIC(4,DA,99,"I"))
- KILL DIC,DIQ,DA,DR,ECXDIC
- End DoDot:3
- +12 if $Y+3>IOSL
- DO HDR
- if QFLG
- QUIT
- +13 WRITE !?1,ECEX,?11,ECDT,?25,ECFR,"-",ECTO,?48,$JUSTIFY(ECRC,9),?60,ECTRN,?75,ECXDIV
- End DoDot:2
- End DoDot:1
- +14 GOTO QUIT
- HDR ;HEADER
- +1 IF $EXTRACT(IOST)="C"
- SET SS=22-$Y
- FOR JJ=1:1:SS
- WRITE !
- +2 IF $EXTRACT(IOST)="C"
- IF PG>0
- SET DIR(0)="E"
- WRITE !
- DO ^DIR
- KILL DIR
- IF 'Y
- SET QFLG=1
- QUIT
- +3 SET PG=PG+1
- if $Y!($EXTRACT(IOST)="C")
- WRITE @IOF
- WRITE !,"DELETABLE EXTRACTS",?72,"Page: ",PG,!,"Printed on ",HDT,!
- +4 WRITE !,"FEEDER SYS",?12,"EXTRACT,",!,"EXTRACT #",?12,"DATE",?33,"FROM-TO",?48,"RECORD CNT",?60,"TRANSMIT DATE",?75,"DIV",!,LN
- +5 QUIT
- DATES ;ask for date range for purge of holding files
- +1 KILL HI,LO,ECBDT,ECEDT
- +2 IF ECY="I"
- Begin DoDot:1
- +3 IF '$ORDER(^ECX(728.113,0))
- WRITE !!,"You have no data in the IVP holding file (file #728.113) to purge."
- QUIT
- +4 SET LO=$ORDER(^ECX(728.113,"A",0))
- SET HI=$ORDER(^ECX(728.113,"A"," "),-1)
- End DoDot:1
- +5 IF ECY="U"
- Begin DoDot:1
- +6 IF '$ORDER(^ECX(728.904,0))
- WRITE !!,"You have no data in the UDP holding file (file #728.904) to purge."
- QUIT
- +7 SET LO=$ORDER(^ECX(728.904,"A",0))
- SET HI=$ORDER(^ECX(728.904,"A"," "),-1)
- End DoDot:1
- +8 IF ECY="V"
- Begin DoDot:1
- +9 IF '$ORDER(^VBEC(6002.03,0))
- WRITE !!,"You have no data in the VBECS holding file (file #6002.03) to purge."
- QUIT
- +10 SET LO=$ORDER(^VBEC(6002.03,"C",0))
- SET HI=$ORDER(^VBEC(6002.03,"C"," "),-1)
- End DoDot:1
- +11 if $GET(LO)=""
- QUIT
- +12 WRITE @IOF,!!,"This file currently holds ",$SELECT(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," data from <",$$FMTE^XLFDT(LO,"D"),"> to <",$$FMTE^XLFDT(HI,"D"),">."
- +13 WRITE !
- KILL DIR
- SET DIR(0)="DA^"_LO_":"_HI_":EPX"
- SET DIR("A")="Beginning date for purge: "
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL HI,LO
- QUIT
- +14 SET ECBDT=+Y
- +15 KILL DIR
- SET DIR(0)="DA^"_ECBDT_":"_HI_":EPX"
- SET DIR("A")="Ending date for purge: "
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL HI,LO,ECBDT
- QUIT
- +16 SET ECEDT=+Y
- ASK4 ; ask to confirm date range
- +1 WRITE !!,"I will purge the ",$SELECT(ECY="I":"IVP",ECY="U":"UDP",1:"VBECS")," holding file from <",$$FMTE^XLFDT(ECBDT,"D"),"> to <",$$FMTE^XLFDT(ECEDT,"D"),">."
- +2 WRITE !!
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Is this OK"
- SET DIR("B")="NO"
- +3 SET DIR("?",1)=" Enter:"
- +4 SET DIR("?",2)=" ""YES"" if you agree with this date range and wish to proceed,"
- +5 SET DIR("?",3)=" ""NO"" if you would like to make a different selection, or"
- +6 SET DIR("?")=" ""^"" to exit option."
- +7 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- KILL ECBDT,ECEDT
- QUIT
- +8 IF 'Y
- GOTO DATES
- +9 ; at this point, ECBDT and ECEDT are passed back to ^ECXPURG
- +10 QUIT
- +11 ;
- DIVCHK(ECLOC,ECTMP) ;**Remove extracts from ECLOC that are for user's div.
- +1 NEW ECLPDA
- +2 SET ECLPDA=0
- +3 FOR
- SET ECLPDA=$ORDER(ECLOC(ECLPDA))
- if (+ECLPDA=0)
- QUIT
- Begin DoDot:1
- +4 IF '$DATA(ECTMP($PIECE(^ECX(727,ECLPDA,"DIV"),U,1)))
- KILL ECLOC(ECLPDA)
- End DoDot:1
- +5 QUIT
- CBOCCHK(ECLOC) ;**Check that CBOC report has been viewed prior to deleting
- +1 NEW LOOPDA,YYYMMDD
- +2 SET LOOPDA=0
- +3 FOR
- SET LOOPDA=$ORDER(ECLOC(LOOPDA))
- if (+LOOPDA=0)
- QUIT
- Begin DoDot:1
- +4 IF ^ECX(727,LOOPDA,"HEAD")="CLI"
- Begin DoDot:2
- +5 SET DA(1)=1
- +6 SET YYYMMDD=$PIECE(^ECX(727,LOOPDA,0),U,4)
- +7 IF YYYMMDD>3030930
- IF '$DATA(^ECX(728,DA(1),"CBOC","B",LOOPDA))
- Begin DoDot:3
- +8 ;144
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="The CBOC Activity Report has not been viewed. Delete anyway"
- SET DIR("B")="NO"
- +9 DO ^DIR
- KILL DIR
- IF 'Y
- KILL ECLOC(LOOPDA)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 QUIT
