- 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 Mar 13, 2025@21:31:34 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
