PRCFARRA ;WISC@ALTOONA/CTB-RELEASE RECEIVING REPORTS IN 442.9 TO AUSTIN ;2/1/95 13:35
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S PRCF("X")="AS" D ^PRCFSITE Q:'%
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
W ! S %A="Have you printed and reviewed the list of Receiving Reports",%A(1)="to be released",%B="",%=2 D ^PRCFYN Q:%<0
I %=2 W !!,"Please review the list for accuracy before continuing." H 3 G OUT
W ! S %A="Are you ready to continue",%B="",%=2 D ^PRCFYN G:%'=1 OUT
D ES^PRCFACR I $D(FAIL) K FAIL G OUT
S ZTDESC="RELEASE RECEIVING REPORTS TO AUSTIN",ZTRTN="QUE^PRCFARRA",ZTSAVE("DUZ")="",ZTSAVE("PRC*")="",ZTDTH=$H D ^PRCFQ
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
DELETE ;DELETE ENTRY FROM FILE 442.9
S PRCF("X")="AS" D ^PRCFSITE Q:'%
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
S %A="OK to delete",%B="",%=2 D ^PRCFYN Q:%<0 G DELETE:%=2
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
PRINT ;PRINT LIST OF RECEIVING REPORTS
S PRCF("X")="AS" D ^PRCFSITE I '% S X="Inadequate information to continue.*" D MSG^PRCFQ G OUT
S DIC="^PRC(442.9,",L=0,(BY,FLDS)="[PRCFA RECEIVING REPORT LIST]" D EN1^DIP Q
QUE ;RELEASE RECEIVING REPORTS IN 442.9 FOR PRC("SITE")
D:$D(ZTQUEUED) KILL^%ZTLOAD
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
S IOP=PRIOP,DIC="^PRC(442.9,",L=0,(BY,FLDS)="[PRCFA REC RPT TRANS LIST]" D EN1^DIP
D ^%ZISC D NOW^PRCFQ S DT=X K %,%X,X,Y
S DA=0,DIK="^PRC(442.9," F I=1:1 S DA=$O(^PRC(442.9,"AC",1,DA)) Q:'DA D ^DIK
K DIK G OUT
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
Q:%<0 Q:$P(X,"^",4)>DT
I $P(X,"^",6)]""!($P(X,"^",7)]"") S DIK="^PRC(442.9,",DA=LDA D ^DIK K DA Q
S PRCFA("PODA")=$P(X,"^",2),PRCFA("PARTIAL")=$P($P(X,"^"),".",2)
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)
S $P(^PRC(442.9,LDA,0),"^",6,7)=XMZ_"^1",^PRC(442.9,"AC",1,LDA)=""
Q
CHANGE ;CHANGE TRANSMISSION DATE
S DIC=442.9,DIC(0)="AEMQ",DIC("A")="Select Receiving Report.Partial Number: " D ^DIC K DIC Q:Y<0
S DA=+Y,DR=3,DIE="^PRC(442.9," D ^DIE W ! S DIC("A")="Select Next Receiving Report.Partial Number: " G CHANGE
AP(X) ;Return Accounting Period for Receiver
N Y S X=^PRC(442.9,X,0),Y=$P(X,U,2),X=$P($P(X,U),".",2)
S Y=$P($G(^PRC(442,Y,11,+X,1)),U,17) ; + added by REW for DAY-0396-41053 - patch 90
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)))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFARRA 3090 printed Nov 22, 2024@17:12:39 Page 2
PRCFARRA ;WISC@ALTOONA/CTB-RELEASE RECEIVING REPORTS IN 442.9 TO AUSTIN ;2/1/95 13:35
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
+4 SET %A="Are you ready to send the receiving reports to Austin"
SET %B="A 'YES' will start the transmission process, a 'NO' or an '^'"
SET %B(1)="will exit this option."
SET %=1
DO ^PRCFYN
IF %'=1
GOTO OUT
+5 WRITE !
SET %A="Have you printed and reviewed the list of Receiving Reports"
SET %A(1)="to be released"
SET %B=""
SET %=2
DO ^PRCFYN
if %<0
QUIT
+6 IF %=2
WRITE !!,"Please review the list for accuracy before continuing."
HANG 3
GOTO OUT
+7 WRITE !
SET %A="Are you ready to continue"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=1
GOTO OUT
+8 DO ES^PRCFACR
IF $DATA(FAIL)
KILL FAIL
GOTO OUT
+9 SET ZTDESC="RELEASE RECEIVING REPORTS TO AUSTIN"
SET ZTRTN="QUE^PRCFARRA"
SET ZTSAVE("DUZ")=""
SET ZTSAVE("PRC*")=""
SET ZTDTH=$HOROLOG
DO ^PRCFQ
OUT KILL %,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
QUIT
DELETE ;DELETE ENTRY FROM FILE 442.9
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
if '%
QUIT
D1 SET DIC=442.9
SET DIC(0)="AEMQ"
if '$DATA(DIC("A"))
SET DIC("A")="Select Receiving Report to be deleted: "
SET DIC("S")="I +^(0)=PRC(""SITE"")"
DO ^DIC
KILL DIC
if Y<0
QUIT
+1 SET %A="OK to delete"
SET %B=""
SET %=2
DO ^PRCFYN
if %<0
QUIT
if %=2
GOTO DELETE
+2 SET DIK="^PRC(442.9,"
SET DA=+Y
DO ^DIK
SET X=" <Deleted from list>*"
DO MSG^PRCFQ
SET DIC("A")="Select Next Receiving Report: "
GOTO D1
PRINT ;PRINT LIST OF RECEIVING REPORTS
+1 SET PRCF("X")="AS"
DO ^PRCFSITE
IF '%
SET X="Inadequate information to continue.*"
DO MSG^PRCFQ
GOTO OUT
+2 SET DIC="^PRC(442.9,"
SET L=0
SET (BY,FLDS)="[PRCFA RECEIVING REPORT LIST]"
DO EN1^DIP
QUIT
QUE ;RELEASE RECEIVING REPORTS IN 442.9 FOR PRC("SITE")
+1 if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 KILL ^PRC(442.9,"AC",1)
SET LDA=0
FOR XJ=1:1
SET LDA=$ORDER(^PRC(442.9,LDA))
if 'LDA
QUIT
IF $DATA(^PRC(442.9,LDA,0))#2
DO A
+3 SET IOP=PRIOP
SET DIC="^PRC(442.9,"
SET L=0
SET (BY,FLDS)="[PRCFA REC RPT TRANS LIST]"
DO EN1^DIP
+4 DO ^%ZISC
DO NOW^PRCFQ
SET DT=X
KILL %,%X,X,Y
+5 SET DA=0
SET DIK="^PRC(442.9,"
FOR I=1:1
SET DA=$ORDER(^PRC(442.9,"AC",1,DA))
if 'DA
QUIT
DO ^DIK
+6 KILL DIK
GOTO OUT
A KILL PRCFA("RETRANS")
SET X=^PRC(442.9,LDA,0)
if +X'=PRC("SITE")
QUIT
SET %=1
FOR I=2:1:4
IF $PIECE(X,"^",I)=""
SET %=-1
QUIT
+1 if %<0
QUIT
if $PIECE(X,"^",4)>DT
QUIT
+2 IF $PIECE(X,"^",6)]""!($PIECE(X,"^",7)]"")
SET DIK="^PRC(442.9,"
SET DA=LDA
DO ^DIK
KILL DA
QUIT
+3 SET PRCFA("PODA")=$PIECE(X,"^",2)
SET PRCFA("PARTIAL")=$PIECE($PIECE(X,"^"),".",2)
+4 if '$DATA(^PRC(442,PRCFA("PODA"),11,PRCFA("PARTIAL"),0))
QUIT
SET PRC("PER")=$PIECE(X,"^",3)
if $PIECE(X,"^",5)=1
SET PRCFA("RETRANS")=""
DO ^PRCFARRT
if $GET(LCKFLG)
QUIT
+5 SET $PIECE(^PRC(442.9,LDA,0),"^",6,7)=XMZ_"^1"
SET ^PRC(442.9,"AC",1,LDA)=""
+6 QUIT
CHANGE ;CHANGE TRANSMISSION DATE
+1 SET DIC=442.9
SET DIC(0)="AEMQ"
SET DIC("A")="Select Receiving Report.Partial Number: "
DO ^DIC
KILL DIC
if Y<0
QUIT
+2 SET DA=+Y
SET DR=3
SET DIE="^PRC(442.9,"
DO ^DIE
WRITE !
SET DIC("A")="Select Next Receiving Report.Partial Number: "
GOTO CHANGE
AP(X) ;Return Accounting Period for Receiver
+1 NEW Y
SET X=^PRC(442.9,X,0)
SET Y=$PIECE(X,U,2)
SET X=$PIECE($PIECE(X,U),".",2)
+2 ; + added by REW for DAY-0396-41053 - patch 90
SET Y=$PIECE($GET(^PRC(442,Y,11,+X,1)),U,17)
+3 SET X=$SELECT(Y="":"",1:$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,+$EXTRACT(Y,4,5))_" "_(1700+$EXTRACT(Y,1,3)))
+4 QUIT X
