PRCSREC4 ;WISC/KMB-REPOST FILE 417.1 ENTRIES ;4/5/95 12:00
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;loop thru file 417.1 entries. try to reset 417.
START ;
W !!,"This option attempts to repost FMS Exception file entries.",!,"Duplicate entries are not posted on the FMS Transactions file."
N COUNT S COUNT=$P($G(^PRCS(417.1,0)),"^",4) W !!,"There are ",+COUNT," transactions in your FMS Exceptions File.",!!
S %=1 W !!!,"Are you ready to begin" D YN^DICN Q:(%=2)!(%=-1) G:%=0 START
K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="LOOP^PRCSREC4",ZTDESC="FMS REPOSTING REPORT" D ^%ZTLOAD,^%ZISC W !,"End of processing" Q
D LOOP,^%ZISC W !,"End of processing" QUIT
LOOP ;
N A,B,AMT,ARRAY,II,FILE,FCP,FY,I,PODA,PONUM,PONUM1,QUARTER,RDA,STATION,STR,STRING,TDATE,TRANCODE,TRANSNUM,COUNTER,USER,X,Y,FLAG,TY,Z1,P
D NOW^%DTC S Y=% D DD^%DT S TY=Y
;
S (FLAG,P,Z1)=0,STR=",,,FY,,FUND,AO,SITE,PGM,FCPRJ,,,,JOB,,OC"
S RDA=0 F S RDA=$O(^PRCS(417.1,RDA)) Q:(+RDA=0)!(Z1="^") D RESET
I FLAG=0 U IO W !,"No transactions were reposted."
QUIT
RESET ;
S STRING=^PRCS(417.1,RDA,0)
F I=4,6,7,8,9,10,14,16 S ARRAY($P(STR,",",I))=$P(STRING,"^",I)
S STATION=ARRAY("SITE"),AMT=$P(STRING,"^",20),QUARTER=$P(STRING,"^",5),FY=$P(STRING,"^",4),TDATE=$P(STRING,"^",22),(PONUM,PONUM1)=$P(STRING,"^",18)
S ARRAY("BFY")=+$$YEAR^PRC0C($P(STRING,"^",2))
S TRANSNUM=$P(STRING,"^",17)_"-"_PONUM_"-"_$E(TDATE,2,7)_"-"_+$P(STRING,"^",19)_"-"_QUARTER
;
CHEC442 ;
S PODA=0,FCP="" S PONUM=$E(PONUM,4,9),PONUM=STATION_"-"_PONUM S:$D(^PRC(442,"B",PONUM)) PODA=$O(^PRC(442,"B",PONUM,0))
I +PODA'=0 S FCP=$P($G(^PRC(442,PODA,0)),"^",3),FCP=+$P(FCP," ") I $D(^PRC(420,STATION,1,FCP,4,FY)) G POST
;
S A="" D FINDCP^PRCSREC Q:A=""
S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0) Q:'B
S FCP=+$P(^PRCD(420.141,B,0),"^",2) Q:+FCP=0
I '$D(^PRC(420,STATION,1,+FCP,4,FY)) Q
;
;
POST ;
S TRANSNUM=TRANSNUM_"-"_FCP
Q:$D(^PRCS(417,"B",TRANSNUM))
S A=STATION_"^"_+FCP_"^"_FY_"^"_QUARTER_"^"_AMT D EBAL^PRCSEZ(A,"O")
S TRANCODE=$P(STRING,"^",17) I TRANCODE'="CC",$E(PONUM1,4,7)'?4A D EBAL^PRCSEZ(A,"C")
S X=TRANSNUM,DIC="^PRCS(417,",DIC(0)="LZ",DLAYGO=417 D ^DIC Q:Y=-1 S FMSDA=+Y K DIC
L +^PRCS(417,FMSDA):5 Q:'$T F I=2:1:20 S $P(^PRCS(417,FMSDA,0),"^",I)=$P(STRING,"^",I)
S $P(^PRCS(417,FMSDA,0),"^",22)=TDATE
S COUNTER=STATION_"-"_FY_"-"_QUARTER_"-"_FCP,$P(^PRCS(417,FMSDA,0),"^",21)=COUNTER,^PRCS(417,"C",COUNTER,FMSDA)=""
S $P(^PRCS(417,FMSDA,1),"^")=1
L -^PRCS(417,FMSDA) S FLAG=1 D:P=0 HDR
D:IOSL-$Y<3 HOLD Q:Z1="^"
U IO W !,TRANSNUM," posted to control point ",FCP,!,"for fiscal year ",FY,", quarter ",QUARTER," for $",AMT
S DA=RDA,DIK="^PRCS(417.1," D ^DIK K DA,DIK
QUIT
;
HOLD G HDR:$D(ZTQUEUED),HDR:IO'=IO(0) W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1="^" D:Z1'="^" HDR Q
;
HDR S P=P+1,II="" U IO W !,"FMS REPOSTING REPORT",?30,TY,?60,"PAGE ",P S $P(II,"-",80)="-" W !,II
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSREC4 3056 printed Dec 13, 2024@02:18:24 Page 2
PRCSREC4 ;WISC/KMB-REPOST FILE 417.1 ENTRIES ;4/5/95 12:00
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;loop thru file 417.1 entries. try to reset 417.
START ;
+1 WRITE !!,"This option attempts to repost FMS Exception file entries.",!,"Duplicate entries are not posted on the FMS Transactions file."
+2 NEW COUNT
SET COUNT=$PIECE($GET(^PRCS(417.1,0)),"^",4)
WRITE !!,"There are ",+COUNT," transactions in your FMS Exceptions File.",!!
+3 SET %=1
WRITE !!!,"Are you ready to begin"
DO YN^DICN
if (%=2)!(%=-1)
QUIT
if %=0
GOTO START
+4 KILL IO("Q")
SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+5 IF $DATA(IO("Q"))
SET ZTRTN="LOOP^PRCSREC4"
SET ZTDESC="FMS REPOSTING REPORT"
DO ^%ZTLOAD
DO ^%ZISC
WRITE !,"End of processing"
QUIT
+6 DO LOOP
DO ^%ZISC
WRITE !,"End of processing"
QUIT
LOOP ;
+1 NEW A,B,AMT,ARRAY,II,FILE,FCP,FY,I,PODA,PONUM,PONUM1,QUARTER,RDA,STATION,STR,STRING,TDATE,TRANCODE,TRANSNUM,COUNTER,USER,X,Y,FLAG,TY,Z1,P
+2 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TY=Y
+3 ;
+4 SET (FLAG,P,Z1)=0
SET STR=",,,FY,,FUND,AO,SITE,PGM,FCPRJ,,,,JOB,,OC"
+5 SET RDA=0
FOR
SET RDA=$ORDER(^PRCS(417.1,RDA))
if (+RDA=0)!(Z1="^")
QUIT
DO RESET
+6 IF FLAG=0
USE IO
WRITE !,"No transactions were reposted."
+7 QUIT
RESET ;
+1 SET STRING=^PRCS(417.1,RDA,0)
+2 FOR I=4,6,7,8,9,10,14,16
SET ARRAY($PIECE(STR,",",I))=$PIECE(STRING,"^",I)
+3 SET STATION=ARRAY("SITE")
SET AMT=$PIECE(STRING,"^",20)
SET QUARTER=$PIECE(STRING,"^",5)
SET FY=$PIECE(STRING,"^",4)
SET TDATE=$PIECE(STRING,"^",22)
SET (PONUM,PONUM1)=$PIECE(STRING,"^",18)
+4 SET ARRAY("BFY")=+$$YEAR^PRC0C($PIECE(STRING,"^",2))
+5 SET TRANSNUM=$PIECE(STRING,"^",17)_"-"_PONUM_"-"_$EXTRACT(TDATE,2,7)_"-"_+$PIECE(STRING,"^",19)_"-"_QUARTER
+6 ;
CHEC442 ;
+1 SET PODA=0
SET FCP=""
SET PONUM=$EXTRACT(PONUM,4,9)
SET PONUM=STATION_"-"_PONUM
if $DATA(^PRC(442,"B",PONUM))
SET PODA=$ORDER(^PRC(442,"B",PONUM,0))
+2 IF +PODA'=0
SET FCP=$PIECE($GET(^PRC(442,PODA,0)),"^",3)
SET FCP=+$PIECE(FCP," ")
IF $DATA(^PRC(420,STATION,1,FCP,4,FY))
GOTO POST
+3 ;
+4 SET A=""
DO FINDCP^PRCSREC
if A=""
QUIT
+5 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
if 'B
QUIT
+6 SET FCP=+$PIECE(^PRCD(420.141,B,0),"^",2)
if +FCP=0
QUIT
+7 IF '$DATA(^PRC(420,STATION,1,+FCP,4,FY))
QUIT
+8 ;
+9 ;
POST ;
+1 SET TRANSNUM=TRANSNUM_"-"_FCP
+2 if $DATA(^PRCS(417,"B",TRANSNUM))
QUIT
+3 SET A=STATION_"^"_+FCP_"^"_FY_"^"_QUARTER_"^"_AMT
DO EBAL^PRCSEZ(A,"O")
+4 SET TRANCODE=$PIECE(STRING,"^",17)
IF TRANCODE'="CC"
IF $EXTRACT(PONUM1,4,7)'?4A
DO EBAL^PRCSEZ(A,"C")
+5 SET X=TRANSNUM
SET DIC="^PRCS(417,"
SET DIC(0)="LZ"
SET DLAYGO=417
DO ^DIC
if Y=-1
QUIT
SET FMSDA=+Y
KILL DIC
+6 LOCK +^PRCS(417,FMSDA):5
if '$TEST
QUIT
FOR I=2:1:20
SET $PIECE(^PRCS(417,FMSDA,0),"^",I)=$PIECE(STRING,"^",I)
+7 SET $PIECE(^PRCS(417,FMSDA,0),"^",22)=TDATE
+8 SET COUNTER=STATION_"-"_FY_"-"_QUARTER_"-"_FCP
SET $PIECE(^PRCS(417,FMSDA,0),"^",21)=COUNTER
SET ^PRCS(417,"C",COUNTER,FMSDA)=""
+9 SET $PIECE(^PRCS(417,FMSDA,1),"^")=1
+10 LOCK -^PRCS(417,FMSDA)
SET FLAG=1
if P=0
DO HDR
+11 if IOSL-$Y<3
DO HOLD
if Z1="^"
QUIT
+12 USE IO
WRITE !,TRANSNUM," posted to control point ",FCP,!,"for fiscal year ",FY,", quarter ",QUARTER," for $",AMT
+13 SET DA=RDA
SET DIK="^PRCS(417.1,"
DO ^DIK
KILL DA,DIK
+14 QUIT
+15 ;
HOLD if $DATA(ZTQUEUED)
GOTO HDR
if IO'=IO(0)
GOTO HDR
WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z1:DTIME
if '$TEST
SET Z1="^"
if Z1'="^"
DO HDR
QUIT
+1 ;
HDR SET P=P+1
SET II=""
USE IO
WRITE !,"FMS REPOSTING REPORT",?30,TY,?60,"PAGE ",P
SET $PIECE(II,"-",80)="-"
WRITE !,II
+1 QUIT
