- 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 Feb 18, 2025@23:32:57 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
