| [613] | 1 | PRCFARRA ;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
|
|---|
| 11 | OUT 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
|
|---|
| 12 | DELETE ;DELETE ENTRY FROM FILE 442.9
|
|---|
| 13 | S PRCF("X")="AS" D ^PRCFSITE Q:'%
|
|---|
| 14 | D1 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
|
|---|
| 17 | PRINT ;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
|
|---|
| 20 | QUE ;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
|
|---|
| 27 | A 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
|
|---|
| 34 | CHANGE ;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
|
|---|
| 37 | AP(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
|
|---|
