- PRCHRP2 ;WISC/KMB/CR UNPAID PC TRANSACTION BY FCP ;6/05/98 11:15
- ;;5.1;IFCAP;**62**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- N BDATE,EDATE,PODATE,PC1,ARR,XXZ,EX,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,PCNUM,ZTR,ZTR1
- N AMT,AMT1,LINE1,LINE2,LSTATUS,PRCST,PRCSJ,ZIP,BOC,CC,CCREC,PP,QSTATUS
- K ^TMP($J)
- ;
- W @IOF,!!,"Detailed Report of Unpaid PC Transactions by FCP"
- ;
- DATE S DIR(0)="D",DIR("A")="P.O. DATE (BEGIN RANGE) ",DIR("B")="T-30"
- D ^DIR Q:$D(DIRUT) S BDATE=Y
- ;
- S DIR("A")="P.O. DATE (END RANGE) ",DIR("B")="T"
- D ^DIR Q:$D(DIRUT) S EDATE=Y
- ;
- I BDATE'<EDATE,BDATE'=EDATE D G DATE
- . W !,"Please enter a valid date range",!
- ;
- W !,"Please select a device for printing this report.",!
- ;
- S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
- ;
- ;Queue the report
- I $D(IO("Q")) D Q
- . S ZTRTN="DETAIL^PRCHRP2"
- . S ZTSAVE("BDATE")=""
- . S ZTSAVE("EDATE")=""
- . D ^%ZTLOAD,^%ZISC Q
- ;
- D DETAIL,^%ZISC Q
- ;
- DETAIL ;
- F ZTR=1,24,29,32,34,37,38,40,41,45,50,51 S ARR(ZTR)=""
- U IO S U="^",(P,EX)=1,ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
- .S ZTR1=+$P($G(^PRC(442,ZP,7)),"^",2) Q:ZTR1=""
- .Q:$D(ARR(ZTR1))
- .S F1=$G(^PRC(442,ZP,0)),F2=$G(^PRC(442,ZP,1)),LINE3=$G(^PRC(442,ZP,2,1,1,1,0))
- .S (PODATE,Y)=$P(F2,"^",15)
- .I PODATE<BDATE!(PODATE>EDATE) Q
- .S STATUS=+$P($G(^PRC(442,ZP,7)),"^",1),LSTATUS=$P($G(^PRCD(442.3,STATUS,0)),"^",1)
- .S PCNUM=$P(F1,"^"),CP=$P(F1,"^",3),CP=$P(CP," ")
- .S ZTR1=+$P($G(^PRC(442,ZP,7)),"^",2) Q:$D(ARR(ZTR1))
- .Q:CP=""
- .S PC1=$P($G(^PRC(442,ZP,23)),"^",8) Q:PC1=""
- .D DD^%DT S TDATE=Y
- .S USER=$P($G(^PRC(440.5,PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^"),VEND=$P(F2,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$P(F1,"^",15),VEND=$E(VEND,1,30)
- .I VEND="SIMPLIFIED",$P($G(^PRC(442,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
- .S LINE1=CP_"^"_PCNUM_"^"_USER_"^"_VEND
- .S CC=$P(F1,"^",5),BOC=$P($G(^PRC(442,ZP,2,1,0)),"^",4),BOC=$E(BOC,1,20)
- .S LINE2=AMT_"^"_TDATE_"^"_CC_"^"_$E(BOC,1,30)
- .S CP=+CP,^TMP($J,CP,ZP,1)=LINE1,^TMP($J,CP,ZP,2)=LINE2,^TMP($J,CP,ZP,3)=LINE3,^TMP($J,CP,ZP,4)=LSTATUS
- ;
- WRITE ;
- I '$D(^TMP($J)) S P=1 D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
- S (TOT,CP,ZP)="" F S CP=$O(^TMP($J,CP)) Q:EX[U Q:CP="" D
- .F S ZP=$O(^TMP($J,CP,ZP)) Q:EX[U Q:ZP="" D
- ..D:P=1 HEADER I (IOSL-$Y)<6 D HOLD Q:EX[U
- ..S LINE1=^TMP($J,CP,ZP,1) W !,$P(LINE1,"^"),?6,$P(LINE1,"^",2),?25,$P(LINE1,"^",3),?50,$P(LINE1,"^",4)
- ..S AMT1=$P(^TMP($J,CP,ZP,2),"^",1) W !,?3,$J(AMT1,0,2),?20,$P(^TMP($J,CP,ZP,2),"^",2),?36,$P(^TMP($J,CP,ZP,2),"^",3),?50,$P(^TMP($J,CP,ZP,2),"^",4)
- ..W !,^TMP($J,CP,ZP,3),!,^TMP($J,CP,ZP,4),!
- ..S TOT=TOT+AMT1
- .I EX'[U W !,?40,"CONTROL POINT ",CP," SUBTOTAL: ",$J(TOT,0,2),! S TOT=0
- QUIT
- ;
- HOLD G HEADER:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX=U S:'$T EX=U D:EX'=U HEADER Q
- ;
- W @IOF
- W !,"DETAILED REPORT OF UNPAID PURCHASE CARD TRANSACTIONS BY FCP",?65,"PAGE: ",P
- W !,"FCP",?6,"PC NUMBER",?25,"BUYER",?50,"VENDOR"
- W !,?3,"AMOUNT",?20,"PURCHASE DATE",?36,"COST CENTER",?50,"BUDGET OBJECT CODE",!,"FIRST LINE ITEM DESCRIPTION",!,"STATUS"
- W ! F I=1:1:10 W "--------"
- S P=P+1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHRP2 3297 printed Feb 18, 2025@23:36:41 Page 2
- PRCHRP2 ;WISC/KMB/CR UNPAID PC TRANSACTION BY FCP ;6/05/98 11:15
- +1 ;;5.1;IFCAP;**62**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- +1 NEW BDATE,EDATE,PODATE,PC1,ARR,XXZ,EX,CP,VEND,USER,STATUS,TDATE,EDATE,FDATE,DIR,ZP,P,X,Y,F1,F2,LINE3,TOT,PCNUM,ZTR,ZTR1
- +2 NEW AMT,AMT1,LINE1,LINE2,LSTATUS,PRCST,PRCSJ,ZIP,BOC,CC,CCREC,PP,QSTATUS
- +3 KILL ^TMP($JOB)
- +4 ;
- +5 WRITE @IOF,!!,"Detailed Report of Unpaid PC Transactions by FCP"
- +6 ;
- DATE SET DIR(0)="D"
- SET DIR("A")="P.O. DATE (BEGIN RANGE) "
- SET DIR("B")="T-30"
- +1 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET BDATE=Y
- +2 ;
- +3 SET DIR("A")="P.O. DATE (END RANGE) "
- SET DIR("B")="T"
- +4 DO ^DIR
- if $DATA(DIRUT)
- QUIT
- SET EDATE=Y
- +5 ;
- +6 IF BDATE'<EDATE
- IF BDATE'=EDATE
- Begin DoDot:1
- +7 WRITE !,"Please enter a valid date range",!
- End DoDot:1
- GOTO DATE
- +8 ;
- +9 WRITE !,"Please select a device for printing this report.",!
- +10 ;
- +11 SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +12 ;
- +13 ;Queue the report
- +14 IF $DATA(IO("Q"))
- Begin DoDot:1
- +15 SET ZTRTN="DETAIL^PRCHRP2"
- +16 SET ZTSAVE("BDATE")=""
- +17 SET ZTSAVE("EDATE")=""
- +18 DO ^%ZTLOAD
- DO ^%ZISC
- QUIT
- End DoDot:1
- QUIT
- +19 ;
- +20 DO DETAIL
- DO ^%ZISC
- QUIT
- +21 ;
- DETAIL ;
- +1 FOR ZTR=1,24,29,32,34,37,38,40,41,45,50,51
- SET ARR(ZTR)=""
- +2 USE IO
- SET U="^"
- SET (P,EX)=1
- SET ZP=""
- FOR
- SET ZP=$ORDER(^PRC(442,"F",25,ZP))
- if ZP=""
- QUIT
- Begin DoDot:1
- +3 SET ZTR1=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
- if ZTR1=""
- QUIT
- +4 if $DATA(ARR(ZTR1))
- QUIT
- +5 SET F1=$GET(^PRC(442,ZP,0))
- SET F2=$GET(^PRC(442,ZP,1))
- SET LINE3=$GET(^PRC(442,ZP,2,1,1,1,0))
- +6 SET (PODATE,Y)=$PIECE(F2,"^",15)
- +7 IF PODATE<BDATE!(PODATE>EDATE)
- QUIT
- +8 SET STATUS=+$PIECE($GET(^PRC(442,ZP,7)),"^",1)
- SET LSTATUS=$PIECE($GET(^PRCD(442.3,STATUS,0)),"^",1)
- +9 SET PCNUM=$PIECE(F1,"^")
- SET CP=$PIECE(F1,"^",3)
- SET CP=$PIECE(CP," ")
- +10 SET ZTR1=+$PIECE($GET(^PRC(442,ZP,7)),"^",2)
- if $DATA(ARR(ZTR1))
- QUIT
- +11 if CP=""
- QUIT
- +12 SET PC1=$PIECE($GET(^PRC(442,ZP,23)),"^",8)
- if PC1=""
- QUIT
- +13 DO DD^%DT
- SET TDATE=Y
- +14 SET USER=$PIECE($GET(^PRC(440.5,PC1,0)),"^",8)
- SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
- SET VEND=$PIECE(F2,"^")
- SET VEND=$PIECE($GET(^PRC(440,+VEND,0)),"^")
- SET AMT=$PIECE(F1,"^",15)
- SET VEND=$EXTRACT(VEND,1,30)
- +15 IF VEND="SIMPLIFIED"
- IF $PIECE($GET(^PRC(442,ZP,24)),"^",2)'=""
- SET VEND=$PIECE($GET(^PRC(442,ZP,24)),"^",2)
- +16 SET LINE1=CP_"^"_PCNUM_"^"_USER_"^"_VEND
- +17 SET CC=$PIECE(F1,"^",5)
- SET BOC=$PIECE($GET(^PRC(442,ZP,2,1,0)),"^",4)
- SET BOC=$EXTRACT(BOC,1,20)
- +18 SET LINE2=AMT_"^"_TDATE_"^"_CC_"^"_$EXTRACT(BOC,1,30)
- +19 SET CP=+CP
- SET ^TMP($JOB,CP,ZP,1)=LINE1
- SET ^TMP($JOB,CP,ZP,2)=LINE2
- SET ^TMP($JOB,CP,ZP,3)=LINE3
- SET ^TMP($JOB,CP,ZP,4)=LSTATUS
- End DoDot:1
- +20 ;
- WRITE ;
- +1 IF '$DATA(^TMP($JOB))
- SET P=1
- DO HEADER
- WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
- QUIT
- +2 SET (TOT,CP,ZP)=""
- FOR
- SET CP=$ORDER(^TMP($JOB,CP))
- if EX[U
- QUIT
- if CP=""
- QUIT
- Begin DoDot:1
- +3 FOR
- SET ZP=$ORDER(^TMP($JOB,CP,ZP))
- if EX[U
- QUIT
- if ZP=""
- QUIT
- Begin DoDot:2
- +4 if P=1
- DO HEADER
- IF (IOSL-$Y)<6
- DO HOLD
- if EX[U
- QUIT
- +5 SET LINE1=^TMP($JOB,CP,ZP,1)
- WRITE !,$PIECE(LINE1,"^"),?6,$PIECE(LINE1,"^",2),?25,$PIECE(LINE1,"^",3),?50,$PIECE(LINE1,"^",4)
- +6 SET AMT1=$PIECE(^TMP($JOB,CP,ZP,2),"^",1)
- WRITE !,?3,$JUSTIFY(AMT1,0,2),?20,$PIECE(^TMP($JOB,CP,ZP,2),"^",2),?36,$PIECE(^TMP($JOB,CP,ZP,2),"^",3),?50,$PIECE(^TMP($JOB,CP,ZP,2),"^",4)
- +7 WRITE !,^TMP($JOB,CP,ZP,3),!,^TMP($JOB,CP,ZP,4),!
- +8 SET TOT=TOT+AMT1
- End DoDot:2
- +9 IF EX'[U
- WRITE !,?40,"CONTROL POINT ",CP," SUBTOTAL: ",$JUSTIFY(TOT,0,2),!
- SET TOT=0
- End DoDot:1
- +10 QUIT
- +11 ;
- HOLD if $EXTRACT(IOST)="P"!(IO'=IO(0))
- GOTO HEADER
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX=U
- if '$TEST
- SET EX=U
- if EX'=U
- DO HEADER
- QUIT
- +1 ;
- +1 WRITE @IOF
- +2 WRITE !,"DETAILED REPORT OF UNPAID PURCHASE CARD TRANSACTIONS BY FCP",?65,"PAGE: ",P
- +3 WRITE !,"FCP",?6,"PC NUMBER",?25,"BUYER",?50,"VENDOR"
- +4 WRITE !,?3,"AMOUNT",?20,"PURCHASE DATE",?36,"COST CENTER",?50,"BUDGET OBJECT CODE",!,"FIRST LINE ITEM DESCRIPTION",!,"STATUS"
- +5 WRITE !
- FOR I=1:1:10
- WRITE "--------"
- +6 SET P=P+1
- QUIT
