source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDAR.m@ 623

Last change on this file since 623 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1PRCHDAR ;WISC/CR - DELINQUENT APPROVALS REPORT ; 1/19/99 14:47
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 W !
6START K ^TMP($J),^TMP("RECDATE")
7 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
8 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
9 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
10 ;
11 ; Get the last name of first and second card holder entered.
12 S FPERSNL=$P($P(FPERSN,"^",2),",",1),SPERSNL=$P($P(SPERSN,"^",2),",",1)
13 ;
14 ; Get the first name of first and second card holder entered.
15 S FPERSNF=$P(FPERSN,",",2),SPERSNF=$P(SPERSN,",",2)
16 ;
17 I FPERSNL]SPERSNL W !,$C(7),"Less than 'FROM' value.",! K FPERSN,SPERSN,Y G START
18 I (FPERSNL=SPERSNL)&(FPERSNF]SPERSNF) W !,$C(7),"Less than 'FROM' value.",! K FPERSN,SPERSN,Y G START
19 W !
20 ;
21DATE S DIR("A")="START WITH APPROVAL DATE",DIR("?")="Enter the first date for which you wish to see records."
22 S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S FDATE=+Y W " ",Y(0)
23 S DIR("A")="GO TO APPROVAL DATE",DIR("?")="Enter the last date for which you want to see records."
24 S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
25 I EDATE<FDATE W !,$C(7),"Less than 'FROM' value.",! K EDATE,FDATE G DATE
26 W !!,$C(7),?5,"This report should be queued. It may be very large and"
27 W !,?4,"take a long time to generate to the printer. We suggest you"
28 W !,?4,"run it during off hours.",! H 2
29 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
30 I $D(IO("Q")) S ZTRTN="DETAIL^PRCHDAR",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
31 D DETAIL,^%ZISC
32 Q
33 ;
34DETAIL ;
35 D STAT
36 D WRITE
37CLEAN ;
38 K ^TMP($J),^TMP("RECDATE"),APDATE,C1,C2,C3,CARDOFF,EDATE,EX,FDATE
39 K FINALDEL,FPARTIAL,FPERSNF,FPERSN,FPERSNL,GETDATE,I,LINE1,OFFPT
40 K OIEN,ORECD0,ORECD1,ORECD5,P,PARTIAL,PO,PRCHDUZ,RECAPP,RECDATE,RECREQ
41 K SPERSNF,SPERSN,SPERSNL,TIMDATE,USER,USERFN,USERLN
42 K X,X1,XXZ,Y,Z1,ZP
43 Q
44 ;
45STAT ; Get appropriate records from file # 440.6
46 S ZP="" F S ZP=$O(^PRCH(440.6,"PO",ZP)) Q:ZP="" D
47 .S Z1=$G(^PRC(442,ZP,0)),PO=$P(Z1,"^",1) Q:PO=""
48 .I $D(PRC("SITE")) Q:$P(Z1,"-",1)'=PRC("SITE")
49 .;
50 .; Get the receiving required code and the IEN of the Oracle record.
51 .S RECREQ=$P($G(^PRC(442,ZP,23)),"^",15)
52 .S OIEN="" F S OIEN=$O(^PRCH(440.6,"PO",ZP,OIEN)) Q:OIEN="" D
53 ..S ORECD0=$G(^PRCH(440.6,OIEN,0))
54 ..S ORECD1=$G(^PRCH(440.6,OIEN,1))
55 ..S ORECD5=$G(^PRCH(440.6,OIEN,5))
56 ..S PRCHDUZ=+$P(ORECD1,"^",5),USER=$P($G(^VA(200,PRCHDUZ,0)),"^"),USERLN=$P(USER,",",1),USERFN=$P(USER,",",2)
57 ..S OFFPT=+$P(ORECD5,"^",7),CARDOFF=$P($G(^VA(200,OFFPT,0)),"^") I CARDOFF="" S CARDOFF="OFFICIAL NOT ASSIGNED"
58 ..Q:(USER="")!(OFFPT="")
59 ..;
60 ..; Check that user found is within range specified at the beginning.
61 ..I (FPERSNL]USERLN) Q
62 ..I (USERLN]SPERSNL) Q
63 ..I (USERLN=SPERSNL)&(USERFN]SPERSNF) Q
64 ..;
65 ..; Ignore orders not reconciled, without final charge, and not fully
66 ..; received.
67 ..Q:$P(ORECD0,"^",16)'["R"
68 ..Q:$P(ORECD1,"^",4)'["Y"
69 ..Q:$P(ORECD1,"^",3)'["Y"
70 ..;
71 ..; RECAPP=reconciliation interval, CARDOFF=card official.
72 ..; APDATE=approval date by official.
73 ..; RECDATE=reconciliation date by card holder.
74 ..;
75 ..S RECDATE=$P(ORECD1,"^",6) Q:RECDATE=""
76 ..S APDATE=$P(ORECD5,"^",6) Q:APDATE=""
77 ..Q:APDATE<FDATE
78 ..Q:APDATE>EDATE
79 ..Q:APDATE=RECDATE
80 ..;
81 ..; Check if receiving is required and date/time of last partial delivery.
82 ..I RECREQ["Y" D
83 ...S PARTIAL=+$P($G(^PRC(442,ZP,11,0)),"^",3)
84 ...I PARTIAL>0 S FPARTIAL=$G(^PRC(442,ZP,11,PARTIAL,0))
85 ...S GETDATE=$P($G(FPARTIAL),"^",1),FINALDEL=$P($G(FPARTIAL),"^",9)
86 ...I FINALDEL["F"&(GETDATE]"")&(GETDATE>RECDATE) S RECDATE=GETDATE
87 ..;
88 ..Q:RECDATE>EDATE
89 ..S X=RECDATE,X1=APDATE D ^XUWORKDY S RECAPP=X
90 ..S Y=RECDATE D DD^%DT S RECDATE=Y I RECDATE["@" S ^TMP("RECDATE",$J)=1
91 ..S Y=APDATE D DD^%DT S APDATE=Y
92 ..;
93 ..; Get those orders with more than 15 days elapsed from date of final
94 ..; reconciliation by the card holder to approval by the approving official.
95 ..;
96 ..I RECAPP>15 D
97 ...S ^TMP($J,USER,OFFPT,ZP)=USER_"^"_PO_"^"_RECDATE_"^"_APDATE_"^"_RECAPP_"^"_CARDOFF
98 Q
99 ;
100WRITE ; Let's print out what we have.
101 ;
102 S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
103 U IO S U="^",(EX,P)=1
104 I '$D(^TMP($J)) S C1="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
105 ;
106 S C1="" F S C1=$O(^TMP($J,C1)) Q:C1="" Q:EX[U D
107 .D HEADER
108 .S C2="" F S C2=$O(^TMP($J,C1,C2)) Q:C2="" Q:EX[U D
109 ..S C3="" F S C3=$O(^TMP($J,C1,C2,C3)) Q:C3="" Q:EX[U D
110 ...S LINE1=^TMP($J,C1,C2,C3) D
111 ....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),!
112 ....I (IOSL-$Y)<2 D HOLD
113 .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 !
114 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.",!
115 Q
116 ;
117HOLD 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
118 Q
119 ;
120HEADER ;
121 W @IOF
122 W !,"DELINQUENT APPROVALS EXCEPTION LISTING",?45,TIMDATE,?69,"PAGE ",P,!
123 W !,"PURCHASE",?14,"FINAL RECONCILE",?34,"APPROVAL",?47,"RECON TO",!
124 W "ORDER",?14,"DATE",?34,"DATE",?47,"APPR INTER",?59,"CARD OFFICIAL"
125 ;
126 W ! F I=1:1:10 W "--------"
127 W !
128 W !,?10,"CARD HOLDER: ",C1,!
129 S P=P+1
130 Q
Note: See TracBrowser for help on using the repository browser.