PRCHDAR ;WISC/CR - DELINQUENT APPROVALS REPORT ; 1/19/99 14:47
;;5.1;IFCAP;**8**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
W !
START K ^TMP($J),^TMP("RECDATE")
S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
S DIC="^VA(200,",DIC("A")="START WITH CARD HOLDER: ",DIC(0)="AEMQ" D ^DIC K DIC Q:'$D(^VA(200,+Y)) S FPERSN=Y K Y
S DIC="^VA(200,",DIC("A")="GO TO CARD HOLDER: ",DIC(0)="AEMQ" D ^DIC K DIC Q:'$D(^VA(200,+Y)) S SPERSN=Y K Y
;
; Get the last name of first and second card holder entered.
S FPERSNL=$P($P(FPERSN,"^",2),",",1),SPERSNL=$P($P(SPERSN,"^",2),",",1)
;
; Get the first name of first and second card holder entered.
S FPERSNF=$P(FPERSN,",",2),SPERSNF=$P(SPERSN,",",2)
;
I FPERSNL]SPERSNL W !,$C(7),"Less than 'FROM' value.",! K FPERSN,SPERSN,Y G START
I (FPERSNL=SPERSNL)&(FPERSNF]SPERSNF) W !,$C(7),"Less than 'FROM' value.",! K FPERSN,SPERSN,Y G START
W !
;
DATE S DIR("A")="START WITH APPROVAL 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")="GO TO APPROVAL DATE",DIR("?")="Enter the last date for which you want to see records."
S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
I EDATE<FDATE W !,$C(7),"Less than 'FROM' value.",! K EDATE,FDATE G DATE
W !!,$C(7),?5,"This report should be queued. It may be very large and"
W !,?4,"take a long time to generate to the printer. We suggest you"
W !,?4,"run it during off hours.",! H 2
S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="DETAIL^PRCHDAR",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
D DETAIL,^%ZISC
Q
;
DETAIL ;
D STAT
D WRITE
CLEAN ;
K ^TMP($J),^TMP("RECDATE"),APDATE,C1,C2,C3,CARDOFF,EDATE,EX,FDATE
K FINALDEL,FPARTIAL,FPERSNF,FPERSN,FPERSNL,GETDATE,I,LINE1,OFFPT
K OIEN,ORECD0,ORECD1,ORECD5,P,PARTIAL,PO,PRCHDUZ,RECAPP,RECDATE,RECREQ
K SPERSNF,SPERSN,SPERSNL,TIMDATE,USER,USERFN,USERLN
K X,X1,XXZ,Y,Z1,ZP
Q
;
STAT ; Get appropriate records from file # 440.6
S ZP="" F S ZP=$O(^PRCH(440.6,"PO",ZP)) Q:ZP="" D
.S Z1=$G(^PRC(442,ZP,0)),PO=$P(Z1,"^",1) Q:PO=""
.I $D(PRC("SITE")) Q:$P(Z1,"-",1)'=PRC("SITE")
.;
.; Get the receiving required code and the IEN of the Oracle record.
.S RECREQ=$P($G(^PRC(442,ZP,23)),"^",15)
.S OIEN="" F S OIEN=$O(^PRCH(440.6,"PO",ZP,OIEN)) Q:OIEN="" D
..S ORECD0=$G(^PRCH(440.6,OIEN,0))
..S ORECD1=$G(^PRCH(440.6,OIEN,1))
..S ORECD5=$G(^PRCH(440.6,OIEN,5))
..S PRCHDUZ=+$P(ORECD1,"^",5),USER=$P($G(^VA(200,PRCHDUZ,0)),"^"),USERLN=$P(USER,",",1),USERFN=$P(USER,",",2)
..S OFFPT=+$P(ORECD5,"^",7),CARDOFF=$P($G(^VA(200,OFFPT,0)),"^") I CARDOFF="" S CARDOFF="OFFICIAL NOT ASSIGNED"
..Q:(USER="")!(OFFPT="")
..;
..; Check that user found is within range specified at the beginning.
..I (FPERSNL]USERLN) Q
..I (USERLN]SPERSNL) Q
..I (USERLN=SPERSNL)&(USERFN]SPERSNF) Q
..;
..; Ignore orders not reconciled, without final charge, and not fully
..; received.
..Q:$P(ORECD0,"^",16)'["R"
..Q:$P(ORECD1,"^",4)'["Y"
..Q:$P(ORECD1,"^",3)'["Y"
..;
..; RECAPP=reconciliation interval, CARDOFF=card official.
..; APDATE=approval date by official.
..; RECDATE=reconciliation date by card holder.
..;
..S RECDATE=$P(ORECD1,"^",6) Q:RECDATE=""
..S APDATE=$P(ORECD5,"^",6) Q:APDATE=""
..Q:APDATE<FDATE
..Q:APDATE>EDATE
..Q:APDATE=RECDATE
..;
..; Check if receiving is required and date/time of last partial delivery.
..I RECREQ["Y" D
...S PARTIAL=+$P($G(^PRC(442,ZP,11,0)),"^",3)
...I PARTIAL>0 S FPARTIAL=$G(^PRC(442,ZP,11,PARTIAL,0))
...S GETDATE=$P($G(FPARTIAL),"^",1),FINALDEL=$P($G(FPARTIAL),"^",9)
...I FINALDEL["F"&(GETDATE]"")&(GETDATE>RECDATE) S RECDATE=GETDATE
..;
..Q:RECDATE>EDATE
..S X=RECDATE,X1=APDATE D ^XUWORKDY S RECAPP=X
..S Y=RECDATE D DD^%DT S RECDATE=Y I RECDATE["@" S ^TMP("RECDATE",$J)=1
..S Y=APDATE D DD^%DT S APDATE=Y
..;
..; Get those orders with more than 15 days elapsed from date of final
..; reconciliation by the card holder to approval by the approving official.
..;
..I RECAPP>15 D
...S ^TMP($J,USER,OFFPT,ZP)=USER_"^"_PO_"^"_RECDATE_"^"_APDATE_"^"_RECAPP_"^"_CARDOFF
Q
;
WRITE ; Let's print out what we have.
;
S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
U IO S U="^",(EX,P)=1
I '$D(^TMP($J)) S C1="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
;
S C1="" F S C1=$O(^TMP($J,C1)) Q:C1="" Q:EX[U D
.D HEADER
.S C2="" F S C2=$O(^TMP($J,C1,C2)) Q:C2="" Q:EX[U D
..S C3="" F S C3=$O(^TMP($J,C1,C2,C3)) Q:C3="" Q:EX[U D
...S LINE1=^TMP($J,C1,C2,C3) D
....W $P(LINE1,"^",2),?14,$E($P(LINE1,"^",3),1,18),?34,$P(LINE1,"^",4),?52,$P(LINE1,"^",5),?59,$E($P(LINE1,"^",6),1,21),!
....I (IOSL-$Y)<2 D HOLD
.I $E(IOST,1,2)'="P-",EX'[U W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U W !
I $G(^TMP("RECDATE",$J))=1 W !?2,"'@' - This symbol indicates the final Date/Time of receipt",!,?8,"of the PC order by the user or the Warehouse if applicable.",!
Q
;
HOLD G HEADER:$E(IOST,1,2)="P-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U D:EX'=U HEADER
Q
;
W @IOF
W !,"DELINQUENT APPROVALS EXCEPTION LISTING",?45,TIMDATE,?69,"PAGE ",P,!
W !,"PURCHASE",?14,"FINAL RECONCILE",?34,"APPROVAL",?47,"RECON TO",!
W "ORDER",?14,"DATE",?34,"DATE",?47,"APPR INTER",?59,"CARD OFFICIAL"
;
W ! F I=1:1:10 W "--------"
W !
W !,?10,"CARD HOLDER: ",C1,!
S P=P+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDAR 5571 printed Dec 13, 2024@02:06:33 Page 2
PRCHDAR ;WISC/CR - DELINQUENT APPROVALS REPORT ; 1/19/99 14:47
+1 ;;5.1;IFCAP;**8**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 WRITE !
START KILL ^TMP($JOB),^TMP("RECDATE")
+1 SET PRCF("X")="S"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))
QUIT
if $GET(X)="^"
QUIT
+2 SET DIC="^VA(200,"
SET DIC("A")="START WITH CARD HOLDER: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if '$DATA(^VA(200,+Y))
QUIT
SET FPERSN=Y
KILL Y
+3 SET DIC="^VA(200,"
SET DIC("A")="GO TO CARD HOLDER: "
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if '$DATA(^VA(200,+Y))
QUIT
SET SPERSN=Y
KILL Y
+4 ;
+5 ; Get the last name of first and second card holder entered.
+6 SET FPERSNL=$PIECE($PIECE(FPERSN,"^",2),",",1)
SET SPERSNL=$PIECE($PIECE(SPERSN,"^",2),",",1)
+7 ;
+8 ; Get the first name of first and second card holder entered.
+9 SET FPERSNF=$PIECE(FPERSN,",",2)
SET SPERSNF=$PIECE(SPERSN,",",2)
+10 ;
+11 IF FPERSNL]SPERSNL
WRITE !,$CHAR(7),"Less than 'FROM' value.",!
KILL FPERSN,SPERSN,Y
GOTO START
+12 IF (FPERSNL=SPERSNL)&(FPERSNF]SPERSNF)
WRITE !,$CHAR(7),"Less than 'FROM' value.",!
KILL FPERSN,SPERSN,Y
GOTO START
+13 WRITE !
+14 ;
DATE SET DIR("A")="START WITH APPROVAL DATE"
SET DIR("?")="Enter the first date for which you wish to see records."
+1 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET FDATE=+Y
WRITE " ",Y(0)
+2 SET DIR("A")="GO TO APPROVAL DATE"
SET DIR("?")="Enter the last date for which you want to see records."
+3 SET DIR(0)="D^^"
DO ^DIR
KILL DIR
if +Y<1
QUIT
SET EDATE=+Y
WRITE " ",Y(0)
+4 IF EDATE<FDATE
WRITE !,$CHAR(7),"Less than 'FROM' value.",!
KILL EDATE,FDATE
GOTO DATE
+5 WRITE !!,$CHAR(7),?5,"This report should be queued. It may be very large and"
+6 WRITE !,?4,"take a long time to generate to the printer. We suggest you"
+7 WRITE !,?4,"run it during off hours.",!
HANG 2
+8 SET %ZIS("B")=""
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+9 IF $DATA(IO("Q"))
SET ZTRTN="DETAIL^PRCHDAR"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+10 DO DETAIL
DO ^%ZISC
+11 QUIT
+12 ;
DETAIL ;
+1 DO STAT
+2 DO WRITE
CLEAN ;
+1 KILL ^TMP($JOB),^TMP("RECDATE"),APDATE,C1,C2,C3,CARDOFF,EDATE,EX,FDATE
+2 KILL FINALDEL,FPARTIAL,FPERSNF,FPERSN,FPERSNL,GETDATE,I,LINE1,OFFPT
+3 KILL OIEN,ORECD0,ORECD1,ORECD5,P,PARTIAL,PO,PRCHDUZ,RECAPP,RECDATE,RECREQ
+4 KILL SPERSNF,SPERSN,SPERSNL,TIMDATE,USER,USERFN,USERLN
+5 KILL X,X1,XXZ,Y,Z1,ZP
+6 QUIT
+7 ;
STAT ; Get appropriate records from file # 440.6
+1 SET ZP=""
FOR
SET ZP=$ORDER(^PRCH(440.6,"PO",ZP))
if ZP=""
QUIT
Begin DoDot:1
+2 SET Z1=$GET(^PRC(442,ZP,0))
SET PO=$PIECE(Z1,"^",1)
if PO=""
QUIT
+3 IF $DATA(PRC("SITE"))
if $PIECE(Z1,"-",1)'=PRC("SITE")
QUIT
+4 ;
+5 ; Get the receiving required code and the IEN of the Oracle record.
+6 SET RECREQ=$PIECE($GET(^PRC(442,ZP,23)),"^",15)
+7 SET OIEN=""
FOR
SET OIEN=$ORDER(^PRCH(440.6,"PO",ZP,OIEN))
if OIEN=""
QUIT
Begin DoDot:2
+8 SET ORECD0=$GET(^PRCH(440.6,OIEN,0))
+9 SET ORECD1=$GET(^PRCH(440.6,OIEN,1))
+10 SET ORECD5=$GET(^PRCH(440.6,OIEN,5))
+11 SET PRCHDUZ=+$PIECE(ORECD1,"^",5)
SET USER=$PIECE($GET(^VA(200,PRCHDUZ,0)),"^")
SET USERLN=$PIECE(USER,",",1)
SET USERFN=$PIECE(USER,",",2)
+12 SET OFFPT=+$PIECE(ORECD5,"^",7)
SET CARDOFF=$PIECE($GET(^VA(200,OFFPT,0)),"^")
IF CARDOFF=""
SET CARDOFF="OFFICIAL NOT ASSIGNED"
+13 if (USER="")!(OFFPT="")
QUIT
+14 ;
+15 ; Check that user found is within range specified at the beginning.
+16 IF (FPERSNL]USERLN)
QUIT
+17 IF (USERLN]SPERSNL)
QUIT
+18 IF (USERLN=SPERSNL)&(USERFN]SPERSNF)
QUIT
+19 ;
+20 ; Ignore orders not reconciled, without final charge, and not fully
+21 ; received.
+22 if $PIECE(ORECD0,"^",16)'["R"
QUIT
+23 if $PIECE(ORECD1,"^",4)'["Y"
QUIT
+24 if $PIECE(ORECD1,"^",3)'["Y"
QUIT
+25 ;
+26 ; RECAPP=reconciliation interval, CARDOFF=card official.
+27 ; APDATE=approval date by official.
+28 ; RECDATE=reconciliation date by card holder.
+29 ;
+30 SET RECDATE=$PIECE(ORECD1,"^",6)
if RECDATE=""
QUIT
+31 SET APDATE=$PIECE(ORECD5,"^",6)
if APDATE=""
QUIT
+32 if APDATE<FDATE
QUIT
+33 if APDATE>EDATE
QUIT
+34 if APDATE=RECDATE
QUIT
+35 ;
+36 ; Check if receiving is required and date/time of last partial delivery.
+37 IF RECREQ["Y"
Begin DoDot:3
+38 SET PARTIAL=+$PIECE($GET(^PRC(442,ZP,11,0)),"^",3)
+39 IF PARTIAL>0
SET FPARTIAL=$GET(^PRC(442,ZP,11,PARTIAL,0))
+40 SET GETDATE=$PIECE($GET(FPARTIAL),"^",1)
SET FINALDEL=$PIECE($GET(FPARTIAL),"^",9)
+41 IF FINALDEL["F"&(GETDATE]"")&(GETDATE>RECDATE)
SET RECDATE=GETDATE
End DoDot:3
+42 ;
+43 if RECDATE>EDATE
QUIT
+44 SET X=RECDATE
SET X1=APDATE
DO ^XUWORKDY
SET RECAPP=X
+45 SET Y=RECDATE
DO DD^%DT
SET RECDATE=Y
IF RECDATE["@"
SET ^TMP("RECDATE",$JOB)=1
+46 SET Y=APDATE
DO DD^%DT
SET APDATE=Y
+47 ;
+48 ; Get those orders with more than 15 days elapsed from date of final
+49 ; reconciliation by the card holder to approval by the approving official.
+50 ;
+51 IF RECAPP>15
Begin DoDot:3
+52 SET ^TMP($JOB,USER,OFFPT,ZP)=USER_"^"_PO_"^"_RECDATE_"^"_APDATE_"^"_RECAPP_"^"_CARDOFF
End DoDot:3
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
WRITE ; Let's print out what we have.
+1 ;
+2 SET X=DT
DO NOW^%DTC
DO YX^%DTC
SET TIMDATE=Y
+3 USE IO
SET U="^"
SET (EX,P)=1
+4 IF '$DATA(^TMP($JOB))
SET C1=""
DO HEADER
WRITE !!!!,?10,"*** NO RECORDS TO PRINT ***"
QUIT
+5 ;
+6 SET C1=""
FOR
SET C1=$ORDER(^TMP($JOB,C1))
if C1=""
QUIT
if EX[U
QUIT
Begin DoDot:1
+7 DO HEADER
+8 SET C2=""
FOR
SET C2=$ORDER(^TMP($JOB,C1,C2))
if C2=""
QUIT
if EX[U
QUIT
Begin DoDot:2
+9 SET C3=""
FOR
SET C3=$ORDER(^TMP($JOB,C1,C2,C3))
if C3=""
QUIT
if EX[U
QUIT
Begin DoDot:3
+10 SET LINE1=^TMP($JOB,C1,C2,C3)
Begin DoDot:4
+11 WRITE $PIECE(LINE1,"^",2),?14,$EXTRACT($PIECE(LINE1,"^",3),1,18),?34,$PIECE(LINE1,"^",4),?52,$PIECE(LINE1,"^",5),?59,$EXTRACT($PIECE(LINE1,"^",6),1,21),!
+12 IF (IOSL-$Y)<2
DO HOLD
End DoDot:4
End DoDot:3
End DoDot:2
+13 IF $EXTRACT(IOST,1,2)'="P-"
IF EX'[U
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ[U
SET EX=U
if '$TEST
SET EX=U
WRITE !
End DoDot:1
+14 IF $GET(^TMP("RECDATE",$JOB))=1
WRITE !?2,"'@' - This symbol indicates the final Date/Time of receipt",!,?8,"of the PC order by the user or the Warehouse if applicable.",!
+15 QUIT
+16 ;
HOLD if $EXTRACT(IOST,1,2)="P-"!(IO'=IO(0))
GOTO HEADER
WRITE !,"Press return to continue, '^' to exit: "
READ XXZ:DTIME
if XXZ[U
SET EX=U
if '$TEST
SET EX=U
if EX'=U
DO HEADER
+1 QUIT
+2 ;
+1 WRITE @IOF
+2 WRITE !,"DELINQUENT APPROVALS EXCEPTION LISTING",?45,TIMDATE,?69,"PAGE ",P,!
+3 WRITE !,"PURCHASE",?14,"FINAL RECONCILE",?34,"APPROVAL",?47,"RECON TO",!
+4 WRITE "ORDER",?14,"DATE",?34,"DATE",?47,"APPR INTER",?59,"CARD OFFICIAL"
+5 ;
+6 WRITE !
FOR I=1:1:10
WRITE "--------"
+7 WRITE !
+8 WRITE !,?10,"CARD HOLDER: ",C1,!
+9 SET P=P+1
+10 QUIT
