source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFARRA.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 3.0 KB
Line 
1PRCFARRA ;WISC@ALTOONA/CTB-RELEASE RECEIVING REPORTS IN 442.9 TO AUSTIN ;2/1/95 13:35
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S PRCF("X")="AS" D ^PRCFSITE Q:'%
5 S %A="Are you ready to send the receiving reports to Austin",%B="A 'YES' will start the transmission process, a 'NO' or an '^'",%B(1)="will exit this option." S %=1 D ^PRCFYN I %'=1 G OUT
6 W ! S %A="Have you printed and reviewed the list of Receiving Reports",%A(1)="to be released",%B="",%=2 D ^PRCFYN Q:%<0
7 I %=2 W !!,"Please review the list for accuracy before continuing." H 3 G OUT
8 W ! S %A="Are you ready to continue",%B="",%=2 D ^PRCFYN G:%'=1 OUT
9 D ES^PRCFACR I $D(FAIL) K FAIL G OUT
10 S ZTDESC="RELEASE RECEIVING REPORTS TO AUSTIN",ZTRTN="QUE^PRCFARRA",ZTSAVE("DUZ")="",ZTSAVE("PRC*")="",ZTDTH=$H D ^PRCFQ
11OUT K %,C,DA,DIJ,DLAYGO,DN,DP,ER,I,IOY,J,K,P,POP,PRC,PRCFA,PRCFN,PRIOP,X1,XJ,XMDUZ,XMKK,XMLOCK,XMMG,XMN,XMQF,XMR,XMSUB,XMT,XMTEXT,XMZ,Y5,ZTDESC,ZTDTH,ZTRTN,ZTSAVE Q
12DELETE ;DELETE ENTRY FROM FILE 442.9
13 S PRCF("X")="AS" D ^PRCFSITE Q:'%
14D1 S DIC=442.9,DIC(0)="AEMQ" S:'$D(DIC("A")) DIC("A")="Select Receiving Report to be deleted: " S DIC("S")="I +^(0)=PRC(""SITE"")" D ^DIC K DIC Q:Y<0
15 S %A="OK to delete",%B="",%=2 D ^PRCFYN Q:%<0 G DELETE:%=2
16 S DIK="^PRC(442.9,",DA=+Y D ^DIK S X=" <Deleted from list>*" D MSG^PRCFQ S DIC("A")="Select Next Receiving Report: " G D1
17PRINT ;PRINT LIST OF RECEIVING REPORTS
18 S PRCF("X")="AS" D ^PRCFSITE I '% S X="Inadequate information to continue.*" D MSG^PRCFQ G OUT
19 S DIC="^PRC(442.9,",L=0,(BY,FLDS)="[PRCFA RECEIVING REPORT LIST]" D EN1^DIP Q
20QUE ;RELEASE RECEIVING REPORTS IN 442.9 FOR PRC("SITE")
21 D:$D(ZTQUEUED) KILL^%ZTLOAD
22 K ^PRC(442.9,"AC",1) S LDA=0 F XJ=1:1 S LDA=$O(^PRC(442.9,LDA)) Q:'LDA I $D(^PRC(442.9,LDA,0))#2 D A
23 S IOP=PRIOP,DIC="^PRC(442.9,",L=0,(BY,FLDS)="[PRCFA REC RPT TRANS LIST]" D EN1^DIP
24 D ^%ZISC D NOW^PRCFQ S DT=X K %,%X,X,Y
25 S DA=0,DIK="^PRC(442.9," F I=1:1 S DA=$O(^PRC(442.9,"AC",1,DA)) Q:'DA D ^DIK
26 K DIK G OUT
27A K PRCFA("RETRANS") S X=^PRC(442.9,LDA,0) Q:+X'=PRC("SITE") S %=1 F I=2:1:4 I $P(X,"^",I)="" S %=-1 Q
28 Q:%<0 Q:$P(X,"^",4)>DT
29 I $P(X,"^",6)]""!($P(X,"^",7)]"") S DIK="^PRC(442.9,",DA=LDA D ^DIK K DA Q
30 S PRCFA("PODA")=$P(X,"^",2),PRCFA("PARTIAL")=$P($P(X,"^"),".",2)
31 Q:'$D(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0)) S PRC("PER")=$P(X,"^",3) S:$P(X,"^",5)=1 PRCFA("RETRANS")="" D ^PRCFARRT Q:$G(LCKFLG)
32 S $P(^PRC(442.9,LDA,0),"^",6,7)=XMZ_"^1",^PRC(442.9,"AC",1,LDA)=""
33 Q
34CHANGE ;CHANGE TRANSMISSION DATE
35 S DIC=442.9,DIC(0)="AEMQ",DIC("A")="Select Receiving Report.Partial Number: " D ^DIC K DIC Q:Y<0
36 S DA=+Y,DR=3,DIE="^PRC(442.9," D ^DIE W ! S DIC("A")="Select Next Receiving Report.Partial Number: " G CHANGE
37AP(X) ;Return Accounting Period for Receiver
38 N Y S X=^PRC(442.9,X,0),Y=$P(X,U,2),X=$P($P(X,U),".",2)
39 S Y=$P($G(^PRC(442,Y,11,+X,1)),U,17) ; + added by REW for DAY-0396-41053 - patch 90
40 S X=$S(Y="":"",1:$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,+$E(Y,4,5))_" "_(1700+$E(Y,1,3)))
41 Q X
Note: See TracBrowser for help on using the repository browser.