- LRCAP67 ;DALISC/FHS - PURGE 67.9 FILE LMIP PHASE 5
- ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- D ^LRPARAM I '$P($G(LRLABKY),U,3) W !!,"Sorry you do not have the proper security Key",!! G END
- W !!?5,"This routine is used to purge data from LAB MONTHLY WORKLOAD file"
- W !,"after it has been transmitted to the national database. It can also be used to"
- W !,"clear the file and recompute data found to be erroneous after review.",!!
- ARCH ;
- W !?10,"If you intend to archive this data have your Site Manager save"
- W !,"in the appropriate manner the global, ^LRO(67.9, to desired media "
- W !,"before deleting any data.",!!
- W !?10,"Do you want a list of monthly compiled data in the file.",!
- S LREND=0 K DIR S DIR(0)="Y" D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT)) END D:Y DIS G:$G(LREND) END
- SELDIV ;
- K DIC S LRINST=$O(^LRO(67.9,0)) I 'LRINST W !!?10,"NO DATA IN THE FILE " G END
- S DIC="^LRO(67.9,"_LRINST_",1,",DIC(0)="AENMZ" D ^DIC G:Y<1 EN S LRDIV=+Y
- SELMT ;
- I '$O(^LRO(67.9,LRINST,1,LRDIV,1,0)) W !!?10,"NO MONTHLY DATA IN THE FILE",! G EN
- K DA,DR S DIC=DIC_LRDIV_",1," D ^DIC G:Y<1 EN W !! S LRDIC=DIC,(LRDA,DA)=+Y,LRMT=$P(Y,U,2),DA(1)=LRDIV,DA(2)=LRINST,DR=0 D EN^DIQ
- S DIR(0)="Y",DIR("A")="You wish to purge "_$$FMTE^XLFDT(LRMT)_" data " D ^DIR
- G END:$D(DUOUT)!($D(DTOUT))!($D(DIRUT)) I Y'=1 G EN
- W !! S DA=LRDA,DIC=LRDIC,DA(1)=LRDIV,DA(2)=LRINST,DR=0 D EN^DIQ
- S DIR(0)="Y",DIR("A")="Are you very certain you wish to remove this Data? " D ^DIR G EN:Y'=1
- W !!?10,"Deleting "_$$FMTE^XLFDT(LRMT)_" DATA ",!
- S DIK=LRDIC D ^DIK W !!,"DATA DELETED",!! G EN
- Q
- ;
- DIS ;
- K %ZIS,IO("Q") S %ZIS="Q" D ^%ZIS S:POP LREND=1 Q:LREND
- I $D(IO("Q")) S ZTRTN="DISDQ^LRCAP67",ZTIO=ION,ZTDESC="Print list of Lab Monthly compiled data" D ^%ZTLOAD S LREND=1 K IO("Q") D ^%ZISC Q
- U IO
- DISDQ ;
- W:$E(IOST,1,2)="C-" @IOF
- S (LREND,LRINST)=0 F S LRINST=$O(^LRO(67.9,LRINST)) Q:LRINST<1 D G:$G(LREND) END I '$G(LRDATA) W !!?10,"NO DATA TO PURGE " G END
- . S LRDIV=0 F S LRDIV=$O(^LRO(67.9,LRINST,1,LRDIV)) Q:LRDIV<1!($G(LREND)) W:$O(^LRO(67.9,LRINST,1,LRDIV,1,0)) !?30,$P(^DIC(4,LRDIV,0),U) D
- . . S LRAD=0 F S LRAD=$O(^LRO(67.9,LRINST,1,LRDIV,1,LRAD)) Q:LRAD<1!($G(LREND)) D
- . . .I ($Y+6)>IOSL D:$E(IOST,1,2)="C-" PAUSE Q:$G(LREND) W @IOF,!!?30,$P(^DIC(4,LRDIV,0),U)
- . . .K DA,DIC,DR S LRDATA=1,DA=LRAD,DA(1)=LRDIV,DA(2)=LRINST,DIC="^LRO(67.9,"_DA(2)_",1,"_DA(1)_",1,",DR=0 D EN^DIQ
- W !! W:$E(IOST,1,2)="P-" @IOF S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") D ^%ZISC Q
- END ;
- K %ZIS,DA,DIC,DIK,DIR,DIRUT,DTOUT,DUOUT,LRAD,LRDA,LRDATA,LRDIC,LREND,LRINST,LRMT,ZTDESC,ZTIO,ZTQUEUED,ZTRTN D ^%ZISC
- Q
- PAUSE ;
- K DIR S DIR(0)="E" D ^DIR
- S:($D(DTOUT))!($D(DUOUT))!($D(DIRUT)) LREND=1 Q:$G(LREND)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAP67 2744 printed Feb 18, 2025@23:38:25 Page 2
- LRCAP67 ;DALISC/FHS - PURGE 67.9 FILE LMIP PHASE 5
- +1 ;;5.2;LAB SERVICE;**201**;Sep 27, 1994
- EN ;
- +1 DO ^LRPARAM
- IF '$PIECE($GET(LRLABKY),U,3)
- WRITE !!,"Sorry you do not have the proper security Key",!!
- GOTO END
- +2 WRITE !!?5,"This routine is used to purge data from LAB MONTHLY WORKLOAD file"
- +3 WRITE !,"after it has been transmitted to the national database. It can also be used to"
- +4 WRITE !,"clear the file and recompute data found to be erroneous after review.",!!
- ARCH ;
- +1 WRITE !?10,"If you intend to archive this data have your Site Manager save"
- +2 WRITE !,"in the appropriate manner the global, ^LRO(67.9, to desired media "
- +3 WRITE !,"before deleting any data.",!!
- +4 WRITE !?10,"Do you want a list of monthly compiled data in the file.",!
- +5 SET LREND=0
- KILL DIR
- SET DIR(0)="Y"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
- GOTO END
- if Y
- DO DIS
- if $GET(LREND)
- GOTO END
- SELDIV ;
- +1 KILL DIC
- SET LRINST=$ORDER(^LRO(67.9,0))
- IF 'LRINST
- WRITE !!?10,"NO DATA IN THE FILE "
- GOTO END
- +2 SET DIC="^LRO(67.9,"_LRINST_",1,"
- SET DIC(0)="AENMZ"
- DO ^DIC
- if Y<1
- GOTO EN
- SET LRDIV=+Y
- SELMT ;
- +1 IF '$ORDER(^LRO(67.9,LRINST,1,LRDIV,1,0))
- WRITE !!?10,"NO MONTHLY DATA IN THE FILE",!
- GOTO EN
- +2 KILL DA,DR
- SET DIC=DIC_LRDIV_",1,"
- DO ^DIC
- if Y<1
- GOTO EN
- WRITE !!
- SET LRDIC=DIC
- SET (LRDA,DA)=+Y
- SET LRMT=$PIECE(Y,U,2)
- SET DA(1)=LRDIV
- SET DA(2)=LRINST
- SET DR=0
- DO EN^DIQ
- +3 SET DIR(0)="Y"
- SET DIR("A")="You wish to purge "_$$FMTE^XLFDT(LRMT)_" data "
- DO ^DIR
- +4 if $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DIRUT))
- GOTO END
- IF Y'=1
- GOTO EN
- +5 WRITE !!
- SET DA=LRDA
- SET DIC=LRDIC
- SET DA(1)=LRDIV
- SET DA(2)=LRINST
- SET DR=0
- DO EN^DIQ
- +6 SET DIR(0)="Y"
- SET DIR("A")="Are you very certain you wish to remove this Data? "
- DO ^DIR
- if Y'=1
- GOTO EN
- +7 WRITE !!?10,"Deleting "_$$FMTE^XLFDT(LRMT)_" DATA ",!
- +8 SET DIK=LRDIC
- DO ^DIK
- WRITE !!,"DATA DELETED",!!
- GOTO EN
- +9 QUIT
- +10 ;
- DIS ;
- +1 KILL %ZIS,IO("Q")
- SET %ZIS="Q"
- DO ^%ZIS
- if POP
- SET LREND=1
- if LREND
- QUIT
- +2 IF $DATA(IO("Q"))
- SET ZTRTN="DISDQ^LRCAP67"
- SET ZTIO=ION
- SET ZTDESC="Print list of Lab Monthly compiled data"
- DO ^%ZTLOAD
- SET LREND=1
- KILL IO("Q")
- DO ^%ZISC
- QUIT
- +3 USE IO
- DISDQ ;
- +1 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +2 SET (LREND,LRINST)=0
- FOR
- SET LRINST=$ORDER(^LRO(67.9,LRINST))
- if LRINST<1
- QUIT
- Begin DoDot:1
- +3 SET LRDIV=0
- FOR
- SET LRDIV=$ORDER(^LRO(67.9,LRINST,1,LRDIV))
- if LRDIV<1!($GET(LREND))
- QUIT
- if $ORDER(^LRO(67.9,LRINST,1,LRDIV,1,0))
- WRITE !?30,$PIECE(^DIC(4,LRDIV,0),U)
- Begin DoDot:2
- +4 SET LRAD=0
- FOR
- SET LRAD=$ORDER(^LRO(67.9,LRINST,1,LRDIV,1,LRAD))
- if LRAD<1!($GET(LREND))
- QUIT
- Begin DoDot:3
- +5 IF ($Y+6)>IOSL
- if $EXTRACT(IOST,1,2)="C-"
- DO PAUSE
- if $GET(LREND)
- QUIT
- WRITE @IOF,!!?30,$PIECE(^DIC(4,LRDIV,0),U)
- +6 KILL DA,DIC,DR
- SET LRDATA=1
- SET DA=LRAD
- SET DA(1)=LRDIV
- SET DA(2)=LRINST
- SET DIC="^LRO(67.9,"_DA(2)_",1,"_DA(1)_",1,"
- SET DR=0
- DO EN^DIQ
- End DoDot:3
- End DoDot:2
- End DoDot:1
- if $GET(LREND)
- GOTO END
- IF '$GET(LRDATA)
- WRITE !!?10,"NO DATA TO PURGE "
- GOTO END
- +7 WRITE !!
- if $EXTRACT(IOST,1,2)="P-"
- WRITE @IOF
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL IO("Q")
- DO ^%ZISC
- QUIT
- END ;
- +1 KILL %ZIS,DA,DIC,DIK,DIR,DIRUT,DTOUT,DUOUT,LRAD,LRDA,LRDATA,LRDIC,LREND,LRINST,LRMT,ZTDESC,ZTIO,ZTQUEUED,ZTRTN
- DO ^%ZISC
- +2 QUIT
- PAUSE ;
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +2 if ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))
- SET LREND=1
- if $GET(LREND)
- QUIT
- +3 QUIT
