- 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 Mar 13, 2025@21:10:03 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
