PRCB1C.m

PRCB1C ;WISC/PLT-FMS documents Inquiry/Regenerate Rejected SA/ST/AT ; 08/16/95  1:45 PM

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 QUIT  ;invalid entry

 ;

EN ;FMS doc inquiry

 D EN^PRC0E("SA:Suballowance;ST:Suballowance Transfer;AT:Allowance Transfer^FMS Budget Document ID: ","D INQ^PRCB1C")

 QUIT

INQ ;dispaly dcocument data

 N A,B,PRCFC,PRCTX,PRCRI

 S PRCTX=$P(X,"^",2),PRCRI(2100.1)=$P(X,"^",4)

 S PRCFC=$TR($G(GECSDATA(2100.1,PRCRI(2100.1),26,"E")),"/","^")

 S $P(PRCFC,"^",6)=$FN($P(PRCFC,"^",6),"",2)

 D:PRCFC]""

 . S A=$$DT^PRC0B2(+PRCFC,"I"),$P(PRCFC,"^",1)=$P(A,"^",5)

 . D @("INQ"_PRCTX)

 QUIT

 ;

 ;

INQSA ;display SA

 F B=1,11,10,2:1:7,9 D EN^DDIOL($J($P("FMS Txn Date^Doc Year^Quarter^Station #^FCP #^$Amount^BBFY^^FMS Action^FY Acctg Per^FMS Acctg Per","^",B),13)_": "_$P(PRCFC,"^",B))

 QUIT

 ;

INQST ;dispaly ST

INQAT ;dispalt AT

 F B=1,11,10,2:1:8 D EN^DDIOL($J($P("FMS Txn Date^Doc Year^Quarter^Station #^From FCP #^$Amount^BBFY^To FCP#^^FY Acctg Per^FMS Acctg Per","^",B),13)_": "_$P(PRCFC,"^",B))

 QUIT

 ;

 ;PRCA data ^1=txn type;txn type...,^2=select document text, ^3=status

EN1 ;rejected FMS document process

 N PRC,PRCA,PRCRI,PRCID,PRCTX,PRCF,PRCFC,PRCLACT

 D EN^PRC0E("SA:Suballowance;ST:Suballowance Transfer;AT:Allowance Transfer^FMS Rejected Budget Document ID: ^~E~R~T~~","D INQ^PRCB1C,EN2^PRCB1C")

 QUIT

 ;

EN2 ;File process rejected fms doc

 N PRCRI,PRCTX,PRCID,PRCFC,PRCFDT,PRCFAC,PRCAP,PRCFP

 S PRCTX=$P(X,"^",2),PRCID=$P(X,"^",3),PRCRI(2100.1)=$P(X,"^",4)

 D EN^DDIOL(" ")

 D DATA^GECSSGET(PRCID,0)

 S PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E") K GECSDATA

 S PRCFDT=$P(PRCFC,"^"),PRCFAC=$P(PRCFC,"/",9)

Q11 S Y(1)="Enter a date you want to send documents to FMS in format: MM/DD/YY"

 S A=$$DT^PRC0B2("T","E"),A=$P(A,"^",5)

 D DT^PRC0A(.X,.Y,"FMS Transaction Date","",A)

 QUIT:Y=""!(Y["^")

 I Y#100=0 W "   Enter precise date!" G Q11

 S Y=$$DT^PRC0B2(Y,"I")

 W "    (",$P(Y,"^",5),")"

 S PRCFDT=+Y,PRCAP=$P($$DT^PRC0B2($E(Y,1,5)_"00","I"),"^",5)

Q115 S Y(1)="Enter a calender (not fiscal year) accounting period in format: MM/YY."

 S Y(2)="NOTE: a closed FMS accounting period will cause documents to be rejected."

 D DT^PRC0A(.X,.Y,"Accounting Period (MM/YY)","O",PRCAP)

 I X=""!(X["^") G Q11

 G:Y<0 Q115

 I Y#100'=0 W "    Enter nonth/year only!" G Q115

 S Y=$$DT^PRC0B2(Y,"I")

 W "    (",$P(Y,"^",5),")"

 S PRCFP=$P(Y,"^",5),X=$$DATE^PRC0C(+Y,"I"),PRCFP=$P(X,"^",9)_$E(X,3,4)_"/"_PRCFP

 G:PRCTX'="SA" Q13

Q12 ;D SC^PRC0A(.X,.Y,"Select FMS Action Code","B^A:Add New Suballowance;C:Inc/Dec Suballowance",PRCFAC)

 ;G Q11:Y=""!(Y["^")

 S Y="C"

 S PRCFAC=Y

Q13 K X,Y D YN^PRC0A(.X,.Y,"Ready To File Regenerated FMS Document","","NO")

 G:Y["^" Q11

 I Y=1 D

 . D:PRCFC]"" @PRCTX,EN^DDIOL("<Filed>")

 QUIT

 ;

EXIT K X,Y

 QUIT

 ;

SA I PRCFAC="A" D FMSSAL(PRCFC,-1)

 I PRCFAC="C" D FMSSAL(PRCFC,1)

 S $P(PRCFC,"/")=PRCFDT,PRCFC=$P(PRCFC,"/",1,8),$P(PRCFC,"/",9)=PRCFP

 D SA^PRCB8A(.X,$TR(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$P(PRCID,"-",2,999))

 QUIT

 ;

ST S $P(PRCFC,"/")=PRCFDT,PRCFC=$P(PRCFC,"/",1,8),$P(PRCFC,"/",9)=PRCFP

 D ST^PRCB8A1(.X,$TR(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$P(PRCID,"-",2,999))

 QUIT

 ;

AT S $P(PRCFC,"/")=PRCFDT,PRCFC=$P(PRCFC,"/",1,8),$P(PRCFC,"/",9)=PRCFP

 D AT^PRCB8A2(.X,$TR(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$P(PRCID,"-",2,999))

 QUIT

 ;

 ;A=file 2100.1 ri, B=status

SAREJ(A,B) ;DCT process rejected sa subroutine

 N GECSDATA,PRCRI,PRCID,PRCFC,PRCDDT,PRCY,PRCQ,PRCSITE,PRCAMT,PRCY

 QUIT:B'="R"

 D DATA^GECSSGET(A,0) QUIT:'$G(GECSDATA)

 S PRCRI(2100.1)=GECSDATA,PRCID=GECSDATA(2100.1,PRCRI(2100.1),.01,"E")

 S PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E")

 K GECSDATA

 D:$P(PRCFC,"/",9)="A" FMSSAL(PRCFC,-1)

 QUIT

 ;

 ;PRCFC=SA document string, PRCA=1 if add, -1 if delete

FMSSAL(PRCFC,PRCA) ;add/delete entry in file 420.141

 N PRCRI,PRCQ,PRCSITE,PRCAMT,PRCY,PRCF

 N A,B

 S PRCFC=$TR($P(PRCFC,"/",1,8),"/","^")

 S PRCY=$P(PRCFC,"^",2),PRCQ=$P(PRCFC,"^",3)

 S PRCSITE=+$P(PRCFC,"^",4),PRCRI(420.01)=+$P(PRCFC,"^",5),PRCAMT=$P(PRCFC,"^",6)

 S PRCY=$$YEAR^PRC0C(PRCY)

 S PRCF=$$ACC^PRC0C(PRCSITE,PRCRI(420.01)_"^"_$E(PRCY,3,4)_"^"_$P(PRCFC,"^",7))

 S A=$$FMSACC^PRC0D(PRCSITE,PRCF)

 S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)

 I PRCA=-1,B D DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)

 I PRCA=1,'B S B=$$A420D141^PRC0F(A,PRCRI(420.01))

 QUIT

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCB1C   4464     printed  Mar 13, 2025@21:05:05                                                                                                                                                                                                      Page 2

PRCB1C    ;WISC/PLT-FMS documents Inquiry/Regenerate Rejected SA/ST/AT ; 08/16/95  1:45 PM

V         ;;5.1;IFCAP;;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2       ;invalid entry

           QUIT 

 +3       ;

EN        ;FMS doc inquiry

 +1        DO EN^PRC0E("SA:Suballowance;ST:Suballowance Transfer;AT:Allowance Transfer^FMS Budget Document ID: ","D INQ^PRCB1C")

 +2        QUIT 

INQ       ;dispaly dcocument data

 +1        NEW A,B,PRCFC,PRCTX,PRCRI

 +2        SET PRCTX=$PIECE(X,"^",2)

           SET PRCRI(2100.1)=$PIECE(X,"^",4)

 +3        SET PRCFC=$TRANSLATE($GET(GECSDATA(2100.1,PRCRI(2100.1),26,"E")),"/","^")

 +4        SET $PIECE(PRCFC,"^",6)=$FNUMBER($PIECE(PRCFC,"^",6),"",2)

 +5        if PRCFC]""

               Begin DoDot:1

 +6                SET A=$$DT^PRC0B2(+PRCFC,"I")

                   SET $PIECE(PRCFC,"^",1)=$PIECE(A,"^",5)

 +7                DO @("INQ"_PRCTX)

               End DoDot:1

 +8        QUIT 

 +9       ;

 +10      ;

INQSA     ;display SA

 +1        FOR B=1,11,10,2:1:7,9

               DO EN^DDIOL($JUSTIFY($PIECE("FMS Txn Date^Doc Year^Quarter^Station #^FCP #^$Amount^BBFY^^FMS Action^FY Acctg Per^FMS Acctg Per","^",B),13)_": "_$PIECE(PRCFC,"^",B))

 +2        QUIT 

 +3       ;

INQST     ;dispaly ST

INQAT     ;dispalt AT

 +1        FOR B=1,11,10,2:1:8

               DO EN^DDIOL($JUSTIFY($PIECE("FMS Txn Date^Doc Year^Quarter^Station #^From FCP #^$Amount^BBFY^To FCP#^^FY Acctg Per^FMS Acctg Per","^",B),13)_": "_$PIECE(PRCFC,"^",B))

 +2        QUIT 

 +3       ;

 +4       ;PRCA data ^1=txn type;txn type...,^2=select document text, ^3=status

EN1       ;rejected FMS document process

 +1        NEW PRC,PRCA,PRCRI,PRCID,PRCTX,PRCF,PRCFC,PRCLACT

 +2        DO EN^PRC0E("SA:Suballowance;ST:Suballowance Transfer;AT:Allowance Transfer^FMS Rejected Budget Document ID: ^~E~R~T~~","D INQ^PRCB1C,EN2^PRCB1C")

 +3        QUIT 

 +4       ;

EN2       ;File process rejected fms doc

 +1        NEW PRCRI,PRCTX,PRCID,PRCFC,PRCFDT,PRCFAC,PRCAP,PRCFP

 +2        SET PRCTX=$PIECE(X,"^",2)

           SET PRCID=$PIECE(X,"^",3)

           SET PRCRI(2100.1)=$PIECE(X,"^",4)

 +3        DO EN^DDIOL(" ")

 +4        DO DATA^GECSSGET(PRCID,0)

 +5        SET PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E")

           KILL GECSDATA

 +6        SET PRCFDT=$PIECE(PRCFC,"^")

           SET PRCFAC=$PIECE(PRCFC,"/",9)

Q11        SET Y(1)="Enter a date you want to send documents to FMS in format: MM/DD/YY"

 +1        SET A=$$DT^PRC0B2("T","E")

           SET A=$PIECE(A,"^",5)

 +2        DO DT^PRC0A(.X,.Y,"FMS Transaction Date","",A)

 +3        if Y=""!(Y["^")

               QUIT 

 +4        IF Y#100=0

               WRITE "   Enter precise date!"

               GOTO Q11

 +5        SET Y=$$DT^PRC0B2(Y,"I")

 +6        WRITE "    (",$PIECE(Y,"^",5),")"

 +7        SET PRCFDT=+Y

           SET PRCAP=$PIECE($$DT^PRC0B2($EXTRACT(Y,1,5)_"00","I"),"^",5)

Q115       SET Y(1)="Enter a calender (not fiscal year) accounting period in format: MM/YY."

 +1        SET Y(2)="NOTE: a closed FMS accounting period will cause documents to be rejected."

 +2        DO DT^PRC0A(.X,.Y,"Accounting Period (MM/YY)","O",PRCAP)

 +3        IF X=""!(X["^")

               GOTO Q11

 +4        if Y<0

               GOTO Q115

 +5        IF Y#100'=0

               WRITE "    Enter nonth/year only!"

               GOTO Q115

 +6        SET Y=$$DT^PRC0B2(Y,"I")

 +7        WRITE "    (",$PIECE(Y,"^",5),")"

 +8        SET PRCFP=$PIECE(Y,"^",5)

           SET X=$$DATE^PRC0C(+Y,"I")

           SET PRCFP=$PIECE(X,"^",9)_$EXTRACT(X,3,4)_"/"_PRCFP

 +9        if PRCTX'="SA"

               GOTO Q13

Q12       ;D SC^PRC0A(.X,.Y,"Select FMS Action Code","B^A:Add New Suballowance;C:Inc/Dec Suballowance",PRCFAC)

 +1       ;G Q11:Y=""!(Y["^")

 +2        SET Y="C"

 +3        SET PRCFAC=Y

Q13        KILL X,Y

           DO YN^PRC0A(.X,.Y,"Ready To File Regenerated FMS Document","","NO")

 +1        if Y["^"

               GOTO Q11

 +2        IF Y=1

               Begin DoDot:1

 +3                if PRCFC]""

                       DO @PRCTX

                       DO EN^DDIOL("<Filed>")

               End DoDot:1

 +4        QUIT 

 +5       ;

EXIT       KILL X,Y

 +1        QUIT 

 +2       ;

SA         IF PRCFAC="A"

               DO FMSSAL(PRCFC,-1)

 +1        IF PRCFAC="C"

               DO FMSSAL(PRCFC,1)

 +2        SET $PIECE(PRCFC,"/")=PRCFDT

           SET PRCFC=$PIECE(PRCFC,"/",1,8)

           SET $PIECE(PRCFC,"/",9)=PRCFP

 +3        DO SA^PRCB8A(.X,$TRANSLATE(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$PIECE(PRCID,"-",2,999))

 +4        QUIT 

 +5       ;

ST         SET $PIECE(PRCFC,"/")=PRCFDT

           SET PRCFC=$PIECE(PRCFC,"/",1,8)

           SET $PIECE(PRCFC,"/",9)=PRCFP

 +1        DO ST^PRCB8A1(.X,$TRANSLATE(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$PIECE(PRCID,"-",2,999))

 +2        QUIT 

 +3       ;

AT         SET $PIECE(PRCFC,"/")=PRCFDT

           SET PRCFC=$PIECE(PRCFC,"/",1,8)

           SET $PIECE(PRCFC,"/",9)=PRCFP

 +1        DO AT^PRCB8A2(.X,$TRANSLATE(PRCFC,"/","^"),PRCRI(2100.1)_"^"_$PIECE(PRCID,"-",2,999))

 +2        QUIT 

 +3       ;

 +4       ;A=file 2100.1 ri, B=status

SAREJ(A,B) ;DCT process rejected sa subroutine

 +1        NEW GECSDATA,PRCRI,PRCID,PRCFC,PRCDDT,PRCY,PRCQ,PRCSITE,PRCAMT,PRCY

 +2        if B'="R"

               QUIT 

 +3        DO DATA^GECSSGET(A,0)

           if '$GET(GECSDATA)

               QUIT 

 +4        SET PRCRI(2100.1)=GECSDATA

           SET PRCID=GECSDATA(2100.1,PRCRI(2100.1),.01,"E")

 +5        SET PRCFC=GECSDATA(2100.1,PRCRI(2100.1),26,"E")

 +6        KILL GECSDATA

 +7        if $PIECE(PRCFC,"/",9)="A"

               DO FMSSAL(PRCFC,-1)

 +8        QUIT 

 +9       ;

 +10      ;PRCFC=SA document string, PRCA=1 if add, -1 if delete

FMSSAL(PRCFC,PRCA) ;add/delete entry in file 420.141

 +1        NEW PRCRI,PRCQ,PRCSITE,PRCAMT,PRCY,PRCF

 +2        NEW A,B

 +3        SET PRCFC=$TRANSLATE($PIECE(PRCFC,"/",1,8),"/","^")

 +4        SET PRCY=$PIECE(PRCFC,"^",2)

           SET PRCQ=$PIECE(PRCFC,"^",3)

 +5        SET PRCSITE=+$PIECE(PRCFC,"^",4)

           SET PRCRI(420.01)=+$PIECE(PRCFC,"^",5)

           SET PRCAMT=$PIECE(PRCFC,"^",6)

 +6        SET PRCY=$$YEAR^PRC0C(PRCY)

 +7        SET PRCF=$$ACC^PRC0C(PRCSITE,PRCRI(420.01)_"^"_$EXTRACT(PRCY,3,4)_"^"_$PIECE(PRCFC,"^",7))

 +8        SET A=$$FMSACC^PRC0D(PRCSITE,PRCF)

 +9        SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)

 +10       IF PRCA=-1

               IF B

                   DO DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)

 +11       IF PRCA=1

               IF 'B

                   SET B=$$A420D141^PRC0F(A,PRCRI(420.01))

 +12       QUIT 

 +13      ;