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 Apr 09, 2024@21:06:51 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
