PRCBR1 ;WISC@ALTOONA/CTB-ROUTINE TO RELEASE TRANSACTIONS FROM FUND DISTRIBUTION FILE ; 01/31/94 4:06 PM
V ;;5.1;IFCAP;**139,170**;Oct 20, 2000;Build 7
;Per VHA Directive 2004-038, this routine should not be modified.
SE ;DIRECT ENTRY POINT, UN QUEUED
I $D(ZTQUEUED) D KILL^%ZTLOAD
S X="BUDGET RELEASE" D ^PRCFALCK I '% D REQUE Q
SE1 D NOW^%DTC S DT=X S:'$D(PRCFTIME) PRCFTIME=%
D DUZ^PRCFSITE G:'% OUT
I '$D(^PRCF(421,"AL",PRCF("SIFY"),1)) W !!,"FUND DISTRIBUTION RELEASE ABORTED. NO TRANSACTIONS FOUND FOR STATION NUMBER "_PRC("SITE")_"." G OUT
W:$D(IOF) @IOF W "Beginning transaction release...",!!
C S U="^" K ^PRCF(421,"AI",1),^TMP("PRCB",$J,"CP",2) S DA=0
F ZI=1:1 S DA=$O(^PRCF(421,"AL",PRCF("SIFY"),1,DA)) Q:'DA Q:'$D(^PRCF(421,DA,0)) S PRCB("TRDA")=DA,TRDA(0)=^PRCF(421,DA,0) Q:$P(TRDA(0),"-",1,2)'=PRCF("SIFY") D A Q:$D(PRCFA("QUIT"))
G:$D(PRCFA("QUIT")) OUT S PRCB("CP")=9999 D LOAD
OUT K ^TMP("PRCB",$J,"CP"),%,%D,%H,%I,%M,%X,%Y,BY,C,DA,DHD,DIC,DLAYGO,FLDS,G,I,IOP,J,K,J,M,N,NOW,P,PRCF,PRCFA,PRCB,PRSAL,PRCFTIME,T,X,Y,Z,ZI
D EN^DDIOL("End of Released Transactions List **************")
S X="BUDGET RELEASE" D UNLOCK^PRCFALCK Q
REQUE I '$D(ZTQUEUED) W !!,$C(7),"Try releasing at a later time." Q
S ZTIO=$S($D(PRCFA("NOPRINT")):"@",1:IO) D REQ^%ZTLOAD
Q
A ;PROCEDURE TO DETERMINE IF CONTROL POINT IS AUTOMATED D B IF IT IS, A1 IF ITIS NOT
S PRCB("CK")=0,PRCB("CP")=+($P(TRDA(0),U,2)),PRC("SITE")=+TRDA(0),PRC("FY")=$P(TRDA(0),"-",2)
I $D(^PRC(420,PRC("SITE"),1,PRCB("CP"),0)),$P(^(0),U,11)["Y" D B Q:$D(PRCFA("QUIT")) D:PRCB("CK")'=1 REL Q
D LOAD
S DA=PRCB("TRDA")
S MESSAGE=""
D ENCODE^PRCBES1(DA,DUZ,.MESSAGE)
K MESSAGE
D REL
Q
LOAD ;LOAD ALL TRANSACTIONS FOR A SPECIFIC CONTROL POINT INTO THE 'ON PRINT LIST FIELD AND CROSS REFERENCE
I '$D(^TMP("PRCB",$J,"CP",2,PRCB("CP"))) S ^TMP("PRCB",$J,"CP",2,PRCB("CP"))="",M=0 F J=1:1 S M=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_PRCB("CP"),M)) Q:M="" S ^PRCF(421,"AI",1,M)="",$P(^PRCF(421,M,2),"^",13)=1
Q
B ;RELEASE INDIVIDUAL SEQUENCE NUMBER
D LOAD S PRCFC(1)=+TRDA(0),PRCFC=$P(TRDA(0),U,2),PRCFC(2)=$P(PRCFC," ",1),PRCFC(3)=$P(TRDA(0),U,6),PRC("BBFY")=$P(TRDA(0),"^",23)
S I=PRCFC(2)_"^"_PRC("FY")_"^"_PRC("BBFY"),PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),I),"^",11)
S PRCFC(8)=PRC("APP"),PRCFC(9)=$P($P(TRDA(0),U,1),"-",3) F I=1:1:4 S PRCFC(I+3)=$P(TRDA(0),U,I+6)
F PRCFK=1:1:4 I PRCFC(PRCFK+3)'="",$P($G(^PRCF(421,PRCB("TRDA"),4)),U,PRCFK+6)="" S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRCFK_"-"_PRCFC(2),X=$P(Z,"-",1,2)_"-"_PRCFC(2),PRCB("CK")=1 D EN1 Q:$D(PRCFA("QUIT"))
K PRCFK,PRCFC Q
REL ;KILL NON RELEASE INDICATOR, ENCODE RELEASER AND MARK TRANSACTION
S DA=PRCB("TRDA") K PRCB("CK"),^PRCF(421,"AL",PRCF("SIFY"),1,DA) S ^PRCF(421,"AL",PRCF("SIFY"),2,DA)="",$P(^PRCF(421,DA,0),"^",20)=2
S $P(^PRCF(421,DA,0),"^",18)=DT
S MESSAGE=""
D ENCODE^PRCBES1(DA,DUZ,.MESSAGE)
K MESSAGE
D ^PRCBBUL
W !,"Trans #: ",$P(^PRCF(421,DA,0),U),?22,"FCP: ",$E($P(^PRC(420,PRC("SITE"),1,PRCB("CP"),0),U),1,15)
F II=1:1:4 I $P(^PRCF(421,DA,0),U,II+6)]"" W ?44,"QTR: ",II,$P("ST,ND,RD,TH",",",II),?53,"AMT: ",$J($P(^(0),U,II+6),12,2)," Released.",!
Q
EN1 D EN1^PRCSUT3 G:'X W4 S X1=X
EN2 S DLAYGO=410,DIC=410,DIC(0)="MXLZ" D ^DIC G:Y<0 W5 S DA=+Y S $P(^PRCF(421,PRCB("TRDA"),4),U,PRCFK+6)=DA
S ^PRCS(410,DA,0)=^PRCS(410,DA,0)_"^C^^^"_PRCFC(1),^(4)="^^"_PRCFC(PRCFK+3)_"^"_$P($$DATE^PRC0C("T","E"),"^",7)_"^^^^"_PRCFC(PRCFK+3),^(6)=PRCFC(PRCFK+3)_U_PRCFC(3)_U_PRCFC(9),^(3)=PRCFC_U_PRCFC(8)
S ^PRCS(410,"AN",$E(PRCFC,1,30),DA)=""
S U="^"
S PRCF(7)=U_U_U_$P(PRC("PER"),U,3)_U_$P(PRCFTIME,".")_U_U_PRCFTIME
S ^PRCS(410,DA,7)=PRCF(7)
K PRCF(7)
S MESSAGE=""
D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
K MESSAGE
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRCB("CP"),1)
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_DA,"28.5///^S X="_PRC("BBFY"),"LS")
D ERS410^PRC0G(DA_"^"_"O")
S PRCHOBL=1,X=PRCFC(PRCFK+3) D TRANS1^PRCSES K PRCHOBL
S %X="^PRCF(421,"_PRCB("TRDA")_",1,",%Y="^PRCS(410,DA,""CO""," D %XY^%RCR S PRCB("CK")=2 Q
W4 W !!,"UNABLE TO MAKE ENTRY ",X," IN FILE 410.1, FURTHER PROCESSING TERMINATED. CONTACT YOUR SITE MANAGER." S PRCFA("QUIT")="" R X:2 Q
W5 W !!,"UNABLE TO MAKE ENTRY ",X," IN FILE 410, FURTHER PROCESSING TERMINATED. CONTACT YOUR SITE MANAGER." S PRCFA("QUIT")="" R X:2 Q
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
;PRC*5.1*170 Corrected lock check for DILOCKTM failing Cache 2011 compile
L +@(DIC_DA_")"):$G(DILOCKTM,3) S PRSAL=$T Q:PRSAL'=0 I PRSAL=0 W !!,$C(7),"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER." Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBR1 4597 printed Apr 09, 2024@21:05:22 Page 2
PRCBR1 ;WISC@ALTOONA/CTB-ROUTINE TO RELEASE TRANSACTIONS FROM FUND DISTRIBUTION FILE ; 01/31/94 4:06 PM
V ;;5.1;IFCAP;**139,170**;Oct 20, 2000;Build 7
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
SE ;DIRECT ENTRY POINT, UN QUEUED
+1 IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 SET X="BUDGET RELEASE"
DO ^PRCFALCK
IF '%
DO REQUE
QUIT
SE1 DO NOW^%DTC
SET DT=X
if '$DATA(PRCFTIME)
SET PRCFTIME=%
+1 DO DUZ^PRCFSITE
if '%
GOTO OUT
+2 IF '$DATA(^PRCF(421,"AL",PRCF("SIFY"),1))
WRITE !!,"FUND DISTRIBUTION RELEASE ABORTED. NO TRANSACTIONS FOUND FOR STATION NUMBER "_PRC("SITE")_"."
GOTO OUT
+3 if $DATA(IOF)
WRITE @IOF
WRITE "Beginning transaction release...",!!
C SET U="^"
KILL ^PRCF(421,"AI",1),^TMP("PRCB",$JOB,"CP",2)
SET DA=0
+1 FOR ZI=1:1
SET DA=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),1,DA))
if 'DA
QUIT
if '$DATA(^PRCF(421,DA,0))
QUIT
SET PRCB("TRDA")=DA
SET TRDA(0)=^PRCF(421,DA,0)
if $PIECE(TRDA(0),"-",1,2)'=PRCF("SIFY")
QUIT
DO A
if $DATA(PRCFA("QUIT"))
QUIT
+2 if $DATA(PRCFA("QUIT"))
GOTO OUT
SET PRCB("CP")=9999
DO LOAD
OUT KILL ^TMP("PRCB",$JOB,"CP"),%,%D,%H,%I,%M,%X,%Y,BY,C,DA,DHD,DIC,DLAYGO,FLDS,G,I,IOP,J,K,J,M,N,NOW,P,PRCF,PRCFA,PRCB,PRSAL,PRCFTIME,T,X,Y,Z,ZI
+1 DO EN^DDIOL("End of Released Transactions List **************")
+2 SET X="BUDGET RELEASE"
DO UNLOCK^PRCFALCK
QUIT
REQUE IF '$DATA(ZTQUEUED)
WRITE !!,$CHAR(7),"Try releasing at a later time."
QUIT
+1 SET ZTIO=$SELECT($DATA(PRCFA("NOPRINT")):"@",1:IO)
DO REQ^%ZTLOAD
+2 QUIT
A ;PROCEDURE TO DETERMINE IF CONTROL POINT IS AUTOMATED D B IF IT IS, A1 IF ITIS NOT
+1 SET PRCB("CK")=0
SET PRCB("CP")=+($PIECE(TRDA(0),U,2))
SET PRC("SITE")=+TRDA(0)
SET PRC("FY")=$PIECE(TRDA(0),"-",2)
+2 IF $DATA(^PRC(420,PRC("SITE"),1,PRCB("CP"),0))
IF $PIECE(^(0),U,11)["Y"
DO B
if $DATA(PRCFA("QUIT"))
QUIT
if PRCB("CK")'=1
DO REL
QUIT
+3 DO LOAD
+4 SET DA=PRCB("TRDA")
+5 SET MESSAGE=""
+6 DO ENCODE^PRCBES1(DA,DUZ,.MESSAGE)
+7 KILL MESSAGE
+8 DO REL
+9 QUIT
LOAD ;LOAD ALL TRANSACTIONS FOR A SPECIFIC CONTROL POINT INTO THE 'ON PRINT LIST FIELD AND CROSS REFERENCE
+1 IF '$DATA(^TMP("PRCB",$JOB,"CP",2,PRCB("CP")))
SET ^TMP("PRCB",$JOB,"CP",2,PRCB("CP"))=""
SET M=0
FOR J=1:1
SET M=$ORDER(^PRCF(421,"AC",PRCF("SIFY")_"-"_PRCB("CP"),M))
if M=""
QUIT
SET ^PRCF(421,"AI",1,M)=""
SET $PIECE(^PRCF(421,M,2),"^",13)=1
+2 QUIT
B ;RELEASE INDIVIDUAL SEQUENCE NUMBER
+1 DO LOAD
SET PRCFC(1)=+TRDA(0)
SET PRCFC=$PIECE(TRDA(0),U,2)
SET PRCFC(2)=$PIECE(PRCFC," ",1)
SET PRCFC(3)=$PIECE(TRDA(0),U,6)
SET PRC("BBFY")=$PIECE(TRDA(0),"^",23)
+2 SET I=PRCFC(2)_"^"_PRC("FY")_"^"_PRC("BBFY")
SET PRC("APP")=$PIECE($$ACC^PRC0C(PRC("SITE"),I),"^",11)
+3 SET PRCFC(8)=PRC("APP")
SET PRCFC(9)=$PIECE($PIECE(TRDA(0),U,1),"-",3)
FOR I=1:1:4
SET PRCFC(I+3)=$PIECE(TRDA(0),U,I+6)
+4 FOR PRCFK=1:1:4
IF PRCFC(PRCFK+3)'=""
IF $PIECE($GET(^PRCF(421,PRCB("TRDA"),4)),U,PRCFK+6)=""
SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRCFK_"-"_PRCFC(2)
SET X=$PIECE(Z,"-",1,2)_"-"_PRCFC(2)
SET PRCB("CK")=1
DO EN1
if $DATA(PRCFA("QUIT"))
QUIT
+5 KILL PRCFK,PRCFC
QUIT
REL ;KILL NON RELEASE INDICATOR, ENCODE RELEASER AND MARK TRANSACTION
+1 SET DA=PRCB("TRDA")
KILL PRCB("CK"),^PRCF(421,"AL",PRCF("SIFY"),1,DA)
SET ^PRCF(421,"AL",PRCF("SIFY"),2,DA)=""
SET $PIECE(^PRCF(421,DA,0),"^",20)=2
+2 SET $PIECE(^PRCF(421,DA,0),"^",18)=DT
+3 SET MESSAGE=""
+4 DO ENCODE^PRCBES1(DA,DUZ,.MESSAGE)
+5 KILL MESSAGE
+6 DO ^PRCBBUL
+7 WRITE !,"Trans #: ",$PIECE(^PRCF(421,DA,0),U),?22,"FCP: ",$EXTRACT($PIECE(^PRC(420,PRC("SITE"),1,PRCB("CP"),0),U),1,15)
+8 FOR II=1:1:4
IF $PIECE(^PRCF(421,DA,0),U,II+6)]""
WRITE ?44,"QTR: ",II,$PIECE("ST,ND,RD,TH",",",II),?53,"AMT: ",$JUSTIFY($PIECE(^(0),U,II+6),12,2)," Released.",!
+9 QUIT
EN1 DO EN1^PRCSUT3
if 'X
GOTO W4
SET X1=X
EN2 SET DLAYGO=410
SET DIC=410
SET DIC(0)="MXLZ"
DO ^DIC
if Y<0
GOTO W5
SET DA=+Y
SET $PIECE(^PRCF(421,PRCB("TRDA"),4),U,PRCFK+6)=DA
+1 SET ^PRCS(410,DA,0)=^PRCS(410,DA,0)_"^C^^^"_PRCFC(1)
SET ^(4)="^^"_PRCFC(PRCFK+3)_"^"_$PIECE($$DATE^PRC0C("T","E"),"^",7)_"^^^^"_PRCFC(PRCFK+3)
SET ^(6)=PRCFC(PRCFK+3)_U_PRCFC(3)_U_PRCFC(9)
SET ^(3)=PRCFC_U_PRCFC(8)
+2 SET ^PRCS(410,"AN",$EXTRACT(PRCFC,1,30),DA)=""
+3 SET U="^"
+4 SET PRCF(7)=U_U_U_$PIECE(PRC("PER"),U,3)_U_$PIECE(PRCFTIME,".")_U_U_PRCFTIME
+5 SET ^PRCS(410,DA,7)=PRCF(7)
+6 KILL PRCF(7)
+7 SET MESSAGE=""
+8 DO ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
+9 KILL MESSAGE
+10 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRCB("CP"),1)
+11 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_DA,"28.5///^S X="_PRC("BBFY"),"LS")
+12 DO ERS410^PRC0G(DA_"^"_"O")
+13 SET PRCHOBL=1
SET X=PRCFC(PRCFK+3)
DO TRANS1^PRCSES
KILL PRCHOBL
+14 SET %X="^PRCF(421,"_PRCB("TRDA")_",1,"
SET %Y="^PRCS(410,DA,""CO"","
DO %XY^%RCR
SET PRCB("CK")=2
QUIT
W4 WRITE !!,"UNABLE TO MAKE ENTRY ",X," IN FILE 410.1, FURTHER PROCESSING TERMINATED. CONTACT YOUR SITE MANAGER."
SET PRCFA("QUIT")=""
READ X:2
QUIT
W5 WRITE !!,"UNABLE TO MAKE ENTRY ",X," IN FILE 410, FURTHER PROCESSING TERMINATED. CONTACT YOUR SITE MANAGER."
SET PRCFA("QUIT")=""
READ X:2
QUIT
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
+1 ;PRC*5.1*170 Corrected lock check for DILOCKTM failing Cache 2011 compile
+2 LOCK +@(DIC_DA_")"):$GET(DILOCKTM,3)
SET PRSAL=$TEST
if PRSAL'=0
QUIT
IF PRSAL=0
WRITE !!,$CHAR(7),"THIS ENTRY IS BEING EDITED BY ANOTHER USER. TRY LATER."
QUIT
