- PRCHURP ;WISC/KMB/CR-UNAPPROVED RECONCILIATION ;7/09/98 11:10
- ;;5.1;IFCAP;**8,35**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- N CHK,OFF,CPS,S1,S2,RDATE,LINE1,CRD,PONUM,STRING,AMT,AMT1,FLAG,FLAG1,CP,USER,TDATE,EDATE,FDATE,HDATE,DIR,ZP,P,PRC,X,Y,F1,F2,F3,XXZ,EX
- K ^TMP($J)
- W @IOF
- S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
- S DIR("A")="Enter beginning date",DIR("?")="Enter the first date for which you wish to see records"
- S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S FDATE=+Y W " ",Y(0)
- S DIR("A")="Enter ending date",DIR("?")="Enter the last date for which you wish to see records"
- S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
- I EDATE<FDATE W !,"Date range is incorrect." G START
- S (FLAG,FLAG1)=0,DIR("A")="Do you want to include all the Approving Officials in this report",DIR(0)="Y^^" D ^DIR K DIR Q:Y<0 S FLAG=Y
- ;
- I FLAG=0 S DIC="^VA(200,",DIC(0)="AEMQZ",DIC("A")="Select one Approving Official (or Alternate): ",DIC("S")="I $D(^PRC(440.5,""I"",PRC(""SITE""),+Y))!($D(^PRC(440.5,""J"",PRC(""SITE""),+Y)))" D ^DIC K DIC Q:Y<0 S FLAG1=+Y
- S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
- I $D(IO("Q")) S ZTRTN="DETAIL^PRCHURP",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
- D DETAIL,^%ZISC Q
- ;
- DETAIL ;
- D NOW^%DTC S Y=% D DD^%DT S HDATE=Y
- S (P,EX)=1
- U IO S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D DETAIL1
- D WRITE
- K ^TMP($J)
- QUIT
- ;
- DETAIL1 ;
- S F1=$G(^PRC(442,ZP,0)),F2=$G(^PRC(442,ZP,1)),F3=$G(^PRC(442,ZP,23))
- I $D(PRC("SITE")) Q:$P(F1,"-",1)'=PRC("SITE")
- S Y=$P(F2,"^",15),CP=$P(F1,"^",3),CPS=+CP,CP=$E(CP,1,19)
- Q:CP="" Q:Y<FDATE Q:Y>EDATE
- D DD^%DT S TDATE=Y
- ; quit if order has not been reconciled
- S CHK=$P($G(^PRC(442,ZP,7)),"^") I CHK'=96,CHK'=97 Q
- S Y=$P(F3,"^",19),CRD=$P(F3,"^",8) Q:CRD="" S OFF=$P($G(^PRC(440.5,CRD,0)),"^",9)
- I $G(OFF)="" S OFF="NOT ASSIGNED"
- ; allow the report for Alternate Approving Officials too
- I $G(FLAG)=0,$G(FLAG1)'=OFF S OFF=$P(^PRC(440.5,CRD,0),"^",10) Q:OFF'=$G(FLAG1)
- S:+OFF'=0 OFF=$P(^VA(200,+OFF,0),"^") D DD^%DT S RDATE=Y
- S USER=$P(F3,"^",22),USER=$P($G(^VA(200,+USER,0)),"^"),PONUM=$P(F1,"^"),AMT=$P(F1,"^",15)
- Q:USER="" S LINE1=TDATE_"^"_PONUM_"^"_USER_"^"_CP_"^"_AMT
- S LINE2=RDATE
- S ^TMP($J,OFF,CPS,USER,ZP,1)=LINE1,^TMP($J,OFF,CPS,USER,ZP,2)=LINE2
- QUIT
- ;
- WRITE ;
- I '$D(^TMP($J)) S OFF="",P=1 D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
- S (OFF,S1,S2,ZP)="" F S OFF=$O(^TMP($J,OFF)) Q:EX[U Q:OFF="" D
- .D HEADER
- .F S S1=$O(^TMP($J,OFF,S1)) Q:EX[U Q:S1="" D
- ..F S S2=$O(^TMP($J,OFF,S1,S2)) Q:EX[U Q:S2="" D
- ...F S ZP=$O(^TMP($J,OFF,S1,S2,ZP)) Q:EX[U Q:ZP="" D
- ....I (IOSL-$Y)<6 D HOLD Q:EX[U
- ....S LINE1=^TMP($J,OFF,S1,S2,ZP,1) W !,$P(LINE1,"^"),?15,$P(LINE1,"^",2),?28,$P(LINE1,"^",3),?49,$P(LINE1,"^",4) S AMT1=$P(LINE1,"^",5) W ?72,$J(AMT1,0,2)
- ....W !,?3,^TMP($J,OFF,S1,S2,ZP,2),!
- .I $E(IOST)'="P",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
- W !,"END OF REPORT" QUIT
- ;
- HOLD G HEADER:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U D:EX'=U HEADER Q
- ;
- W @IOF
- W !,"UNAPPROVED RECONCILIATION REPORT",?40,HDATE,?68,"PAGE ",P,!
- W "STATION NUMBER: "_PRC("SITE")
- W !,"PURCHASE DATE",?15,"PC ORDER #",?28,"CARDHOLDER",?49,"FCP",?72,"AMOUNT"
- W !,?3,"DATE RECONCILED"
- W ! F I=1:1:10 W "--------"
- W !!,?10,"APPROVING OFFICIAL: ",OFF,!
- S P=P+1 Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHURP 3521 printed Mar 13, 2025@21:16:11 Page 2
- PRCHURP ;WISC/KMB/CR-UNAPPROVED RECONCILIATION ;7/09/98 11:10
- +1 ;;5.1;IFCAP;**8,35**;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- START ;
- +1 NEW CHK,OFF,CPS,S1,S2,RDATE,LINE1,CRD,PONUM,STRING,AMT,AMT1,FLAG,FLAG1,CP,USER,TDATE,EDATE,FDATE,HDATE,DIR,ZP,P,PRC,X,Y,F1,F2,F3,XXZ,EX
- +2 KILL ^TMP($JOB)
- +3 WRITE @IOF
- +4 SET PRCF("X")="S"
- DO ^PRCFSITE
- if '$DATA(PRC("SITE"))
- QUIT
- if $GET(X)="^"
- QUIT
- +5 SET DIR("A")="Enter beginning date"
- SET DIR("?")="Enter the first date for which you wish to see records"
- +6 SET DIR(0)="D^^"
- DO ^DIR
- KILL DIR
- if +Y<1
- QUIT
- SET FDATE=+Y
- WRITE " ",Y(0)
- +7 SET DIR("A")="Enter ending date"
- SET DIR("?")="Enter the last date for which you wish to see records"
- +8 SET DIR(0)="D^^"
- DO ^DIR
- KILL DIR
- if +Y<1
- QUIT
- SET EDATE=+Y
- WRITE " ",Y(0)
- +9 IF EDATE<FDATE
- WRITE !,"Date range is incorrect."
- GOTO START
- +10 SET (FLAG,FLAG1)=0
- SET DIR("A")="Do you want to include all the Approving Officials in this report"
- SET DIR(0)="Y^^"
- DO ^DIR
- KILL DIR
- if Y<0
- QUIT
- SET FLAG=Y
- +11 ;
- +12 IF FLAG=0
- SET DIC="^VA(200,"
- SET DIC(0)="AEMQZ"
- SET DIC("A")="Select one Approving Official (or Alternate): "
- SET DIC("S")="I $D(^PRC(440.5,""I"",PRC(""SITE""),+Y))!($D(^PRC(440.5,""J"",PRC(""SITE""),+Y)))"
- DO ^DIC
- KILL DIC
- if Y<0
- QUIT
- SET FLAG1=+Y
- +13 SET %ZIS("B")=""
- SET %ZIS="MQ"
- DO ^%ZIS
- if POP
- QUIT
- +14 IF $DATA(IO("Q"))
- SET ZTRTN="DETAIL^PRCHURP"
- SET ZTSAVE("*")=""
- DO ^%ZTLOAD
- DO ^%ZISC
- QUIT
- +15 DO DETAIL
- DO ^%ZISC
- QUIT
- +16 ;
- DETAIL ;
- +1 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET HDATE=Y
- +2 SET (P,EX)=1
- +3 USE IO
- SET ZP=""
- FOR
- SET ZP=$ORDER(^PRC(442,"F",25,ZP))
- if ZP=""
- QUIT
- DO DETAIL1
- +4 DO WRITE
- +5 KILL ^TMP($JOB)
- +6 QUIT
- +7 ;
- DETAIL1 ;
- +1 SET F1=$GET(^PRC(442,ZP,0))
- SET F2=$GET(^PRC(442,ZP,1))
- SET F3=$GET(^PRC(442,ZP,23))
- +2 IF $DATA(PRC("SITE"))
- if $PIECE(F1,"-",1)'=PRC("SITE")
- QUIT
- +3 SET Y=$PIECE(F2,"^",15)
- SET CP=$PIECE(F1,"^",3)
- SET CPS=+CP
- SET CP=$EXTRACT(CP,1,19)
- +4 if CP=""
- QUIT
- if Y<FDATE
- QUIT
- if Y>EDATE
- QUIT
- +5 DO DD^%DT
- SET TDATE=Y
- +6 ; quit if order has not been reconciled
- +7 SET CHK=$PIECE($GET(^PRC(442,ZP,7)),"^")
- IF CHK'=96
- IF CHK'=97
- QUIT
- +8 SET Y=$PIECE(F3,"^",19)
- SET CRD=$PIECE(F3,"^",8)
- if CRD=""
- QUIT
- SET OFF=$PIECE($GET(^PRC(440.5,CRD,0)),"^",9)
- +9 IF $GET(OFF)=""
- SET OFF="NOT ASSIGNED"
- +10 ; allow the report for Alternate Approving Officials too
- +11 IF $GET(FLAG)=0
- IF $GET(FLAG1)'=OFF
- SET OFF=$PIECE(^PRC(440.5,CRD,0),"^",10)
- if OFF'=$GET(FLAG1)
- QUIT
- +12 if +OFF'=0
- SET OFF=$PIECE(^VA(200,+OFF,0),"^")
- DO DD^%DT
- SET RDATE=Y
- +13 SET USER=$PIECE(F3,"^",22)
- SET USER=$PIECE($GET(^VA(200,+USER,0)),"^")
- SET PONUM=$PIECE(F1,"^")
- SET AMT=$PIECE(F1,"^",15)
- +14 if USER=""
- QUIT
- SET LINE1=TDATE_"^"_PONUM_"^"_USER_"^"_CP_"^"_AMT
- +15 SET LINE2=RDATE
- +16 SET ^TMP($JOB,OFF,CPS,USER,ZP,1)=LINE1
- SET ^TMP($JOB,OFF,CPS,USER,ZP,2)=LINE2
- +17 QUIT
- +18 ;
- WRITE ;
- +1 IF '$DATA(^TMP($JOB))
- SET OFF=""
- SET P=1
- DO HEADER
- WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
- QUIT
- +2 SET (OFF,S1,S2,ZP)=""
- FOR
- SET OFF=$ORDER(^TMP($JOB,OFF))
- if EX[U
- QUIT
- if OFF=""
- QUIT
- Begin DoDot:1
- +3 DO HEADER
- +4 FOR
- SET S1=$ORDER(^TMP($JOB,OFF,S1))
- if EX[U
- QUIT
- if S1=""
- QUIT
- Begin DoDot:2
- +5 FOR
- SET S2=$ORDER(^TMP($JOB,OFF,S1,S2))
- if EX[U
- QUIT
- if S2=""
- QUIT
- Begin DoDot:3
- +6 FOR
- SET ZP=$ORDER(^TMP($JOB,OFF,S1,S2,ZP))
- if EX[U
- QUIT
- if ZP=""
- QUIT
- Begin DoDot:4
- +7 IF (IOSL-$Y)<6
- DO HOLD
- if EX[U
- QUIT
- +8 SET LINE1=^TMP($JOB,OFF,S1,S2,ZP,1)
- WRITE !,$PIECE(LINE1,"^"),?15,$PIECE(LINE1,"^",2),?28,$PIECE(LINE1,"^",3),?49,$PIECE(LINE1,"^",4)
- SET AMT1=$PIECE(LINE1,"^",5)
- WRITE ?72,$JUSTIFY(AMT1,0,2)
- +9 WRITE !,?3,^TMP($JOB,OFF,S1,S2,ZP,2),!
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +10 IF $EXTRACT(IOST)'="P"
- IF EX'["^"
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- End DoDot:1
- +11 WRITE !,"END OF REPORT"
- QUIT
- +12 ;
- HOLD if $EXTRACT(IOST)="P"!(IO'=IO(0))
- GOTO HEADER
- WRITE !,"Press return to continue, '^' to exit: "
- READ XXZ:DTIME
- if XXZ["^"
- SET EX="^"
- if '$TEST
- SET EX=U
- if EX'=U
- DO HEADER
- QUIT
- +1 ;
- +1 WRITE @IOF
- +2 WRITE !,"UNAPPROVED RECONCILIATION REPORT",?40,HDATE,?68,"PAGE ",P,!
- +3 WRITE "STATION NUMBER: "_PRC("SITE")
- +4 WRITE !,"PURCHASE DATE",?15,"PC ORDER #",?28,"CARDHOLDER",?49,"FCP",?72,"AMOUNT"
- +5 WRITE !,?3,"DATE RECONCILED"
- +6 WRITE !
- FOR I=1:1:10
- WRITE "--------"
- +7 WRITE !!,?10,"APPROVING OFFICIAL: ",OFF,!
- +8 SET P=P+1
- QUIT
