IBPO ;ALB/CPM - ARCHIVE/PURGING OUTPUTS ; 23-APR-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
LST ; List Archive/Purge Log Entries
S DIC="^IBE(350.6,",FLDS="[IB PURGE LIST LOG ENTRIES]",L=0,(BY,FR,TO)=""
D EN1^DIP
Q
;
;
INQ ; Archive/Purge Log Inquiry
S DIC="^IBE(350.6,",DIC(0)="QEAMZ",DIC("A")="Select LOG #: " D ^DIC K DIC G INQQ:Y<0 S IBDA=+Y
S %ZIS="QM" D ^%ZIS G:POP INQQ
I $D(IO("Q")) S ZTRTN="INQS^IBPO",ZTSAVE("IBDA")="",ZTDESC="ARCHIVE/PURGE LOG INQUIRY" D ^%ZTLOAD K IO("Q") D HOME^%ZIS G INQQ
U IO
;
INQS ; Tasked Entry Point
D NOW^%DTC W:$E(IOST,1,2)["C-" @IOF,*13 W " LOG #: ",IBDA,?15,$S($D(^DIC($P($G(^IBE(350.6,+IBDA,0)),"^",3),0)):$P(^(0),"^"),1:"FILE UNSPECIFIED"),?(IOM-25),$$DAT2^IBOUTL(%),!
F I=1:1:IOM W "="
S IBLOG0=$G(^IBE(350.6,+IBDA,0)),IBLOG1=$G(^(1)),IBLOG2=$G(^(2)),IBLOG3=$G(^(3))
W !!,$J("Search Template : ",27),$S($P(IBLOG0,"^",2)]"":$P(IBLOG0,"^",2),1:"UNSPECIFIED")
S IBX=$S($P(IBLOG3,"^",2):"Purged",$P(IBLOG2,"^",2):"Archived",1:"Found")
W !,$J("# Records "_IBX_" : ",27),+$P(IBLOG0,"^",4)
W !,$J("Log Status : ",27),$P("OPEN^CLOSED^CANCELLED","^",+$P(IBLOG0,"^",5))
F I=1,2,3 D
. S IBNOD="IBLOG"_I,IBNAM=$P("Search^Archive^Purge","^",I)
. Q:@IBNOD=""
. S Y=+@IBNOD W !!,$J(IBNAM_" Begin Date/Time : ",27),$S(Y:$$DAT2^IBOUTL(Y),1:"UNSPECIFIED")
. S Y=$P(@IBNOD,"^",2) W !,$J(IBNAM_" End Date/Time : ",27),$S('Y:"UNSPECIFIED",1:$$DAT2^IBOUTL(Y))
. S Y=$P(@IBNOD,"^",3) W !,$J(IBNAM_" Initiator : ",27),$S($D(^VA(200,Y,0)):$P(^(0),"^"),1:"UNSPECIFIED")
F I=$Y:1:(IOSL-4) W !
I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
Q:$D(ZTQUEUED) D ^%ZISC
INQQ K DIRUT,DUOUT,DTOUT,IBDA,IBLOG0,IBLOG1,IBLOG2,IBLOG3,IBX,X,Y
Q
;
;
TMP ; List Search Template Entries
S IBF=$$SEL^IBPUDEL G TMPQ:'IBF
;
; - display selection
W ! F I=1:1:80 W "-"
W !,"Template entries will be listed for the following file:"
S IBOP=$P(IBD(IBF),"^",2),IBLOG=$P(IBD(IBF),"^",3)
W !,$P($G(^DIC(IBF,0)),"^")," Entries ",$S(IBOP>2:"Archived",1:"Found")," on ",$$DAT2^IBOUTL($P($G(^IBE(350.6,IBLOG,IBOP-1)),"^",2)),!
F I=1:1:80 W "-"
W !!,"Specify Sort Criteria:",!
;
; - print list
S DIC=^DIC(IBF,0,"GL"),L=0,FLDS=$S(IBF=399:".02;L25,.07;L20,.13;L10,.14",IBF=351:".02,.03,.04,.1",1:".02;L25,.08,.05;L10,DATE(#12);""DATE ADDED""")
S BY="[IB ARCHIVE/PURGE #"_$$LOGIEN^IBPU1(IBF)_"],@.02,@",DHD=$P(^DIC(IBF,0),"^")_" SEARCH TEMPLATE"
D EN1^DIP
;
TMPQ K I,IBD,IBF,IBLOG,IBOP,IBTM,IBTMDA,J,K
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBPO 2571 printed Oct 16, 2024@18:27:11 Page 2
IBPO ;ALB/CPM - ARCHIVE/PURGING OUTPUTS ; 23-APR-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
LST ; List Archive/Purge Log Entries
+1 SET DIC="^IBE(350.6,"
SET FLDS="[IB PURGE LIST LOG ENTRIES]"
SET L=0
SET (BY,FR,TO)=""
+2 DO EN1^DIP
+3 QUIT
+4 ;
+5 ;
INQ ; Archive/Purge Log Inquiry
+1 SET DIC="^IBE(350.6,"
SET DIC(0)="QEAMZ"
SET DIC("A")="Select LOG #: "
DO ^DIC
KILL DIC
if Y<0
GOTO INQQ
SET IBDA=+Y
+2 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO INQQ
+3 IF $DATA(IO("Q"))
SET ZTRTN="INQS^IBPO"
SET ZTSAVE("IBDA")=""
SET ZTDESC="ARCHIVE/PURGE LOG INQUIRY"
DO ^%ZTLOAD
KILL IO("Q")
DO HOME^%ZIS
GOTO INQQ
+4 USE IO
+5 ;
INQS ; Tasked Entry Point
+1 DO NOW^%DTC
if $EXTRACT(IOST,1,2)["C-"
WRITE @IOF,*13
WRITE " LOG #: ",IBDA,?15,$SELECT($DATA(^DIC($PIECE($GET(^IBE(350.6,+IBDA,0)),"^",3),0)):$PIECE(^(0),"^"),1:"FILE UNSPECIFIED"),?(IOM-25),$$DAT2^IBOUTL(%),!
+2 FOR I=1:1:IOM
WRITE "="
+3 SET IBLOG0=$GET(^IBE(350.6,+IBDA,0))
SET IBLOG1=$GET(^(1))
SET IBLOG2=$GET(^(2))
SET IBLOG3=$GET(^(3))
+4 WRITE !!,$JUSTIFY("Search Template : ",27),$SELECT($PIECE(IBLOG0,"^",2)]"":$PIECE(IBLOG0,"^",2),1:"UNSPECIFIED")
+5 SET IBX=$SELECT($PIECE(IBLOG3,"^",2):"Purged",$PIECE(IBLOG2,"^",2):"Archived",1:"Found")
+6 WRITE !,$JUSTIFY("# Records "_IBX_" : ",27),+$PIECE(IBLOG0,"^",4)
+7 WRITE !,$JUSTIFY("Log Status : ",27),$PIECE("OPEN^CLOSED^CANCELLED","^",+$PIECE(IBLOG0,"^",5))
+8 FOR I=1,2,3
Begin DoDot:1
+9 SET IBNOD="IBLOG"_I
SET IBNAM=$PIECE("Search^Archive^Purge","^",I)
+10 if @IBNOD=""
QUIT
+11 SET Y=+@IBNOD
WRITE !!,$JUSTIFY(IBNAM_" Begin Date/Time : ",27),$SELECT(Y:$$DAT2^IBOUTL(Y),1:"UNSPECIFIED")
+12 SET Y=$PIECE(@IBNOD,"^",2)
WRITE !,$JUSTIFY(IBNAM_" End Date/Time : ",27),$SELECT('Y:"UNSPECIFIED",1:$$DAT2^IBOUTL(Y))
+13 SET Y=$PIECE(@IBNOD,"^",3)
WRITE !,$JUSTIFY(IBNAM_" Initiator : ",27),$SELECT($DATA(^VA(200,Y,0)):$PIECE(^(0),"^"),1:"UNSPECIFIED")
End DoDot:1
+14 FOR I=$Y:1:(IOSL-4)
WRITE !
+15 IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+16 if $DATA(ZTQUEUED)
QUIT
DO ^%ZISC
INQQ KILL DIRUT,DUOUT,DTOUT,IBDA,IBLOG0,IBLOG1,IBLOG2,IBLOG3,IBX,X,Y
+1 QUIT
+2 ;
+3 ;
TMP ; List Search Template Entries
+1 SET IBF=$$SEL^IBPUDEL
if 'IBF
GOTO TMPQ
+2 ;
+3 ; - display selection
+4 WRITE !
FOR I=1:1:80
WRITE "-"
+5 WRITE !,"Template entries will be listed for the following file:"
+6 SET IBOP=$PIECE(IBD(IBF),"^",2)
SET IBLOG=$PIECE(IBD(IBF),"^",3)
+7 WRITE !,$PIECE($GET(^DIC(IBF,0)),"^")," Entries ",$SELECT(IBOP>2:"Archived",1:"Found")," on ",$$DAT2^IBOUTL($PIECE($GET(^IBE(350.6,IBLOG,IBOP-1)),"^",2)),!
+8 FOR I=1:1:80
WRITE "-"
+9 WRITE !!,"Specify Sort Criteria:",!
+10 ;
+11 ; - print list
+12 SET DIC=^DIC(IBF,0,"GL")
SET L=0
SET FLDS=$SELECT(IBF=399:".02;L25,.07;L20,.13;L10,.14",IBF=351:".02,.03,.04,.1",1:".02;L25,.08,.05;L10,DATE(#12);""DATE ADDED""")
+13 SET BY="[IB ARCHIVE/PURGE #"_$$LOGIEN^IBPU1(IBF)_"],@.02,@"
SET DHD=$PIECE(^DIC(IBF,0),"^")_" SEARCH TEMPLATE"
+14 DO EN1^DIP
+15 ;
TMPQ KILL I,IBD,IBF,IBLOG,IBOP,IBTM,IBTMDA,J,K
+1 QUIT
