PRCH4RPT ;RB/VM-Print Purchase Card exception reports ;09/15/08
V ;;5.1;IFCAP;**125**;Oct 20, 2000;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
;
N PRCA,PRCB
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
RPT ;select card exception/replacement report type
K DIR
S DIR(0)="S^1:ALL Citibank cards with No US Bank replacement #;2:Active Citibank cards with No US Bank replacement #;3:Inactive Citibank cards with US Bank replacement #"
S DIR("A")="Type of Report",DIR("B")="ALL Citibank cards with No US Bank replacement #" D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S PRCDET=Y
DEV ;device
S %ZIS="Q" D ^%ZIS G:POP EXIT K IOP I '$D(IO("Q")) U IO G PRT
I $D(IO("Q")) S ZTIO=ION,ZTSAVE("*")=""
I S ZTRTN="PRT^PRCH4RPT",ZTDESC="IFCAP Purchase Card exceptions/replacements" D ^%ZTLOAD D HOME^%ZIS Q
PRT ;print
;
COMP ;compile reports
S IEN=0,U="^",PAGE=0,CTR=0 K ^TMP($J)
COMP1 S IEN=$O(^PRC(440.5,IEN)) G LIST:IEN=""!(IEN]"@")
S PRCA=$G(^PRC(440.5,IEN,0)),PRCB=$G(^PRC(440.5,IEN,2)) G:PRCA="" COMP1
I $D(PRC("SITE")) G COMP1:$P(PRCB,U,3)'=PRC("SITE")
I PRCA'?1"4486".E G COMP1
I PRCDET=1 D G COMP1
. I '$O(^PRC(440.5,"ARPC",$P(PRCA,U),0)) D SAVE
I PRCDET=2 D G COMP1
. Q:$P(PRCB,U,2)="Y"
. I '$O(^PRC(440.5,"ARPC",$P(PRCA,U),0)) D SAVE
I PRCDET=3 D G COMP1
. Q:$P(PRCB,U,2)'="Y"
. I $O(^PRC(440.5,"ARPC",$P(PRCA,U),0)) D SAVE
G COMP1
SAVE S ^TMP($J,$P(PRCA,U),IEN,0)=PRCA,^TMP($J,$P(PRCA,U),IEN,2)=PRCB,CTR=CTR+1
I PRCDET=3 S ^TMP($J,$P(PRCA,U),IEN,3)=$O(^PRC(440.5,"ARPC",$P(PRCA,U),0))
Q
LIST ;print report
S PCNO=0,IEN=0,END=0,PAGE=0
S HDRW="INACTIVATED CITI # NEW US BANK # CARD HOLDER"
I PRCDET<3 S HDRW="PURCHASE CARD NUMBER CARD HOLDER"
D HDR
L1 S PCNO=$O(^TMP($J,PCNO)),IEN=0 G:PCNO="" EXIT
L2 S IEN=$O(^TMP($J,PCNO,IEN)) I IEN="" G L1
S PRCA=^TMP($J,PCNO,IEN,0),PRCB=^TMP($J,PCNO,IEN,2),PRCC=$G(^TMP($J,PCNO,IEN,3))
I $Y+1>(IOSL-2) D HDR G EXITZ:END
W !
I PRCDET<3 W $P(PRCA,U),?29,$P($G(^VA(200,+$P(PRCA,U,8),0)),U)
I PRCDET=3 W $P(PRCA,U),?25,$P($G(^PRC(440.5,PRCC,0)),U),?48,$P($G(^VA(200,+$P(PRCA,U,8),0)),U)
G L1
HDR ;header
I PAGE>0,$E(IOST,1,2)="C-" S END=$$EOP^PRCH4RPT() Q:END
S PAGE=PAGE+1 W @IOF,!,"STATION: ",$G(PRC("SITE")),?25,"DEPARTMENT OF VETERANS AFFAIRS",?(IOM-10),"Page ",$J(PAGE,3)
S X=$$FMTE^XLFDT($$NOW^XLFDT())
W !,?30,$P($$UP^XLFSTR(X),":",1,2)
W !!,"** ",$P("ALL Citibank cards with No US Bank replacement #^Active Citibank cards with No US Bank replacement #^Inactive Citibank cards with US Bank replacement #",U,PRCDET)
W !!,HDRW,!!
Q
EOP() ; end of page check - return 1 to quit, 0 to continue
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
I $E(IOST,1,2)'="C-" Q 0 ; not to terminal
S DIR(0)="E"
D ^DIR
Q 'Y
EXIT S:$D(ZTQUEUED) ZTREQ="@"
I $G(CTR)=0 W !!?15,"** NO CARDS FOUND MEETING REPORT CRITERIA REQUESTED **"
W !!,"< END OF REPORT >" I $G(PAGE)>0,$E(IOST,1,2)="C-" S END=$$EOP^PRCH4RPT()
EXITZ W:$E(IOST,1,2)'="C-" @IOF
D ^%ZISC
K PRCA,PRCB,PRCF,DIR,DIRUT,DTOUT,PRCDET,POP
K IEN,PAGE,CTR,PCNO,END,PAGE,HDRW,PRCC,X,Y
K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH4RPT 3149 printed Dec 13, 2024@02:05:15 Page 2
PRCH4RPT ;RB/VM-Print Purchase Card exception reports ;09/15/08
V ;;5.1;IFCAP;**125**;Oct 20, 2000;Build 15
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 NEW PRCA,PRCB
+4 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
RPT ;select card exception/replacement report type
+1 KILL DIR
+2 SET DIR(0)="S^1:ALL Citibank cards with No US Bank replacement #;2:Active Citibank cards with No US Bank replacement #;3:Inactive Citibank cards with US Bank replacement #"
+3 SET DIR("A")="Type of Report"
SET DIR("B")="ALL Citibank cards with No US Bank replacement #"
DO ^DIR
+4 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+5 SET PRCDET=Y
DEV ;device
+1 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
KILL IOP
IF '$DATA(IO("Q"))
USE IO
GOTO PRT
+2 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTSAVE("*")=""
+3 IF $TEST
SET ZTRTN="PRT^PRCH4RPT"
SET ZTDESC="IFCAP Purchase Card exceptions/replacements"
DO ^%ZTLOAD
DO HOME^%ZIS
QUIT
PRT ;print
+1 ;
COMP ;compile reports
+1 SET IEN=0
SET U="^"
SET PAGE=0
SET CTR=0
KILL ^TMP($JOB)
COMP1 SET IEN=$ORDER(^PRC(440.5,IEN))
if IEN=""!(IEN]"@")
GOTO LIST
+1 SET PRCA=$GET(^PRC(440.5,IEN,0))
SET PRCB=$GET(^PRC(440.5,IEN,2))
if PRCA=""
GOTO COMP1
+2 IF $DATA(PRC("SITE"))
if $PIECE(PRCB,U,3)'=PRC("SITE")
GOTO COMP1
+3 IF PRCA'?1"4486".E
GOTO COMP1
+4 IF PRCDET=1
Begin DoDot:1
+5 IF '$ORDER(^PRC(440.5,"ARPC",$PIECE(PRCA,U),0))
DO SAVE
End DoDot:1
GOTO COMP1
+6 IF PRCDET=2
Begin DoDot:1
+7 if $PIECE(PRCB,U,2)="Y"
QUIT
+8 IF '$ORDER(^PRC(440.5,"ARPC",$PIECE(PRCA,U),0))
DO SAVE
End DoDot:1
GOTO COMP1
+9 IF PRCDET=3
Begin DoDot:1
+10 if $PIECE(PRCB,U,2)'="Y"
QUIT
+11 IF $ORDER(^PRC(440.5,"ARPC",$PIECE(PRCA,U),0))
DO SAVE
End DoDot:1
GOTO COMP1
+12 GOTO COMP1
SAVE SET ^TMP($JOB,$PIECE(PRCA,U),IEN,0)=PRCA
SET ^TMP($JOB,$PIECE(PRCA,U),IEN,2)=PRCB
SET CTR=CTR+1
+1 IF PRCDET=3
SET ^TMP($JOB,$PIECE(PRCA,U),IEN,3)=$ORDER(^PRC(440.5,"ARPC",$PIECE(PRCA,U),0))
+2 QUIT
LIST ;print report
+1 SET PCNO=0
SET IEN=0
SET END=0
SET PAGE=0
+2 SET HDRW="INACTIVATED CITI # NEW US BANK # CARD HOLDER"
+3 IF PRCDET<3
SET HDRW="PURCHASE CARD NUMBER CARD HOLDER"
+4 DO HDR
L1 SET PCNO=$ORDER(^TMP($JOB,PCNO))
SET IEN=0
if PCNO=""
GOTO EXIT
L2 SET IEN=$ORDER(^TMP($JOB,PCNO,IEN))
IF IEN=""
GOTO L1
+1 SET PRCA=^TMP($JOB,PCNO,IEN,0)
SET PRCB=^TMP($JOB,PCNO,IEN,2)
SET PRCC=$GET(^TMP($JOB,PCNO,IEN,3))
+2 IF $Y+1>(IOSL-2)
DO HDR
if END
GOTO EXITZ
+3 WRITE !
+4 IF PRCDET<3
WRITE $PIECE(PRCA,U),?29,$PIECE($GET(^VA(200,+$PIECE(PRCA,U,8),0)),U)
+5 IF PRCDET=3
WRITE $PIECE(PRCA,U),?25,$PIECE($GET(^PRC(440.5,PRCC,0)),U),?48,$PIECE($GET(^VA(200,+$PIECE(PRCA,U,8),0)),U)
+6 GOTO L1
HDR ;header
+1 IF PAGE>0
IF $EXTRACT(IOST,1,2)="C-"
SET END=$$EOP^PRCH4RPT()
if END
QUIT
+2 SET PAGE=PAGE+1
WRITE @IOF,!,"STATION: ",$GET(PRC("SITE")),?25,"DEPARTMENT OF VETERANS AFFAIRS",?(IOM-10),"Page ",$JUSTIFY(PAGE,3)
+3 SET X=$$FMTE^XLFDT($$NOW^XLFDT())
+4 WRITE !,?30,$PIECE($$UP^XLFSTR(X),":",1,2)
+5 WRITE !!,"** ",$PIECE("ALL Citibank cards with No US Bank replacement #^Active Citibank cards with No US Bank replacement #^Inactive Citibank cards with US Bank replacement #",U,PRCDET)
+6 WRITE !!,HDRW,!!
+7 QUIT
EOP() ; end of page check - return 1 to quit, 0 to continue
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 ; not to terminal
IF $EXTRACT(IOST,1,2)'="C-"
QUIT 0
+4 SET DIR(0)="E"
+5 DO ^DIR
+6 QUIT 'Y
EXIT if $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 IF $GET(CTR)=0
WRITE !!?15,"** NO CARDS FOUND MEETING REPORT CRITERIA REQUESTED **"
+2 WRITE !!,"< END OF REPORT >"
IF $GET(PAGE)>0
IF $EXTRACT(IOST,1,2)="C-"
SET END=$$EOP^PRCH4RPT()
EXITZ if $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+1 DO ^%ZISC
+2 KILL PRCA,PRCB,PRCF,DIR,DIRUT,DTOUT,PRCDET,POP
+3 KILL IEN,PAGE,CTR,PCNO,END,PAGE,HDRW,PRCC,X,Y
+4 KILL ^TMP($JOB)
+5 QUIT
