source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRP3.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: 3.6 KB
Line 
1PRCHRP3 ;WISC/KMB/CR SUMMARY OF UNPAID PURCHASE CARDS ;7/15/98 8:43 AM
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4UNPAID ; create summary report of unpaid purchase card orders
5 N P,PRC,ARR,XXZ,EX,I,CP,HDATE,ZP,TOT,AMT,ZTR,ZTR0,ZTR1
6 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
7 W !,"Please select a device for display/print of this report.",!
8 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
9 I $D(IO("Q")) S ZTRTN="REPORT^PRCHRP3",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC QUIT
10 D REPORT,^%ZISC QUIT
11 ;
12REPORT ;
13 K ^TMP($J) S (EX,P)=1
14 F I=24,29,32,34,37,38,40,41,50,51 S ARR(I)=""
15 S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
16 .S ZTR0=$G(^PRC(442,ZP,0))
17 .I $D(PRC("SITE")) Q:$P(ZTR0,"-")'=PRC("SITE")
18 .S ZTR1=+$P($G(^PRC(442,ZP,7)),"^") Q:ZTR1=""
19 .S ZTR1=$P($G(^PRCD(442.3,ZTR1,0)),"^",2) Q:$D(ARR(ZTR1))
20 .S AMT=$P($G(^PRC(442,ZP,0)),"^",15)
21 .S CP=$P($G(^PRC(442,ZP,0)),"^",3),CP=+$P(CP," ")
22 .Q:CP=0
23 .S:'$D(^TMP($J,CP)) ^TMP($J,CP)=0 S ^TMP($J,CP)=^TMP($J,CP)+AMT
24 I '$D(^TMP($J)) S P=1 D HEADER1 W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
25 S CP="" F S CP=$O(^TMP($J,CP)) Q:CP="" Q:EX="^" D
26 .D:P=1 HEADER1
27 .W !,"CONTROL POINT: ",CP,?40,"TOTAL: $",$J(^TMP($J,CP),0,2)
28 .I (IOSL-$Y)<6 D HOLD1 Q:EX["^"
29 QUIT
30 ;
31HOLD1 G HEADER1:$E(IOST)="P"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'="^" HEADER1 Q
32 ;
33HEADER1 ;
34 W @IOF
35 D NOW^%DTC S Y=$P(%,".") D DD^%DT S HDATE=Y
36 W !,"UNPAID PURCHASE CARD TRANSACTION BY FCP - SUMMARY",?55,HDATE,?70,"PAGE ",P
37 W:$D(PRC("SITE")) !,?15,"STATION #: "_PRC("SITE")
38 W ! F I=1:1:8 W "----------"
39 S P=P+1
40 QUIT
41 ;
42CANDEL ;cancel delivery card transaction
43 N FLG S FLG=1
44CAN ;cancel purchase card transaction
45 N I,TMP1,CREF,CPREF,LABEL,KDA,ZIP,DA,KX,KY D ST^PRCHE Q:'$D(PRC("SITE"))
46 S DIC("A")="P.O./REQ. NO.: ",DIC(0)="AEMQZ",D="C",DIC("S")="I $P(^(0),""^"",2)=25,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80,$P(^(7),""^"")'=45",DIC="^PRC(442,"
47 I $G(FLG)=1 S DIC("S")="I $P(^(0),""^"",2)=1,$P(^(12),""^"",2)="""",$P(^(7),""^"")<80"
48 W !! D IX^DIC K DIC Q:+Y<0 S (DA,KDA)=+Y
49 S LABEL="CAN" S:$G(FLG)=1 LABEL="CANDEL" S CPREF=$P($G(^PRC(442,KDA,0)),"^",3),CPREF=+$P(CPREF," "),ZIP=$O(^PRC(420,"A",DUZ,PRC("SITE"),CPREF,0))
50 I ZIP="" W !,"You are not a user for this transaction's control point." G @LABEL
51 D START^PRCH410
52 S TMP1=$P(^PRC(442,KDA,0),"^",15)
53 S X=$O(^PRCD(442.3,"C",45,0)),$P(^PRC(442,KDA,0),"^",15,16)="0^0" K ^(9) S (KX,KY)=45,DA=KDA
54 Q:$G(^PRCD(442.3,KY,0))=""
55 L +^PRC(442,KDA):5 E W !!,$C(7),?8,"Another user is editing this entry, try later." K KDA Q
56 S X=Y,DIE="^PRC(442,",DR=".5////"_KY D ^DIE L -^PRC(442,KDA) K DIE,DR,X,Y,DA,DIC
57 L +^PRCS(410,CCDA):5 E W !!,$C(7),?8,"Another user is editing this entry, try later." K CCDA Q
58 S DIE="^PRCS(410,",DA=CCDA,DR="20///^S X=TMP1"_";"_"27///^S X=TMP1"_";"_"451////^S X=""""" D ^DIE
59 S $P(^PRCS(410,CCDA,10),U,3)="",$P(^PRCS(410,CCDA,1),U,2)="" I $P($G(^PRCS(410,CCDA,4)),U,5)'="" K ^PRCS(410,"D",$P(^PRCS(410,CCDA,4),U,5),CCDA)
60 S $P(^PRCS(410,CCDA,4),U,5)=""
61 I $D(^PRC(442,KDA,4,0)) S CCNUM=$P($G(^(0)),"^",4) D
62 .Q:CCNUM="" F I=1:1:CCNUM S ^PRCS(410,CCDA,"RM",I,0)=^PRC(442,KDA,4,I,0)
63 .S ^PRCS(410,CCDA,"RM",0)="^442.04^"_CCNUM_"^"_CCNUM
64 S CREF=$P($G(^PRCS(410,CCDA,0)),"^") W !!,"Use transaction ",CREF," to access this record",!,"from your fund control point." H 3
65 W !!,$C(7),"Conversion completed." L -^PRCS(410,CCDA) K CCNUM,CCDA,DA
66 QUIT
67 ;
68R1 S FLG=1
69R2 S:$G(FLG)'=1 FLG=2
70R3 K FLAG D START^PRCHRP5 K FLG,FLAG QUIT
71UR1 S FLG=1
72UR2 S:$G(FLG)'=1 FLG=2
73UR3 K FLAG D START1^PRCHRP5 K FLG,FLAG QUIT
Note: See TracBrowser for help on using the repository browser.