PRCBCS ;WISC@ALTOONA/CTB-WIRMFO/REW-CREATE CODE SHEETS FROM RELEASED TRX ; [7/1/98 3:00pm]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N A,PRCF
K ^PRCF(421,"AN"),^TMP("PRCB",$J,"BCS"),^TMP("PRCB",$J,"TRDA"),^TMP("PRCB",$J,"CODE") S PRCF("X")="BQ" D ^PRCFSITE Q:'%
S X=PRC("QTR"),X(1)="This option will now generate FMS documents for "_X_$S(X=1:"st",X=2:"nd",X=3:"rd",1:"th")_" Quarter, FY "_PRC("FY")
S X(2)="released transactions which have not previously been coded."
Q1 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","O",A)
QUIT:X["^"!(X="")
I Y#100=0 W " Enter precise date!" G Q1
S Y=$$DT^PRC0B2(Y,"I")
W " (",$P(Y,"^",5),")"
;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The FMS Transaction Date should be in the entered fiscal year and quarter.") G Q1
S PRCF("TDATE")=+Y,PRCF("ACCTP")=$P($$DT^PRC0B2($E(Y,1,5)_"00","I"),"^",5)
Q2 S Y(1)="Enter a calendar (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",PRCF("ACCTP"))
I X=""!(X["^") G Q1
G Q2:Y<0
I Y#100'=0 W " Enter month/year only!" G Q2
S Y=$$DT^PRC0B2(Y,"I")
W " (",$P(Y,"^",5),")"
;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The Accounting Period should be in the entered fiscal year and quarter.") G Q2
S PRCF("ACCTP")=$P(Y,"^",5),X=$$DATE^PRC0C(+Y,"I")
S PRCF("ACCTF")=$P(X,"^",9)_$E(X,3,4)_"^"_PRCF("ACCTP")
Q9 D YN^PRC0A(.X,.Y,"Ready to generate FMS documents","O","YES")
QUIT:X["^"!(X="")
G:Y<1 Q1
;S ZTDESC="CREATE BUDGET CODE SHEETS",ZTRTN="DQ^PRCBCS",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("DUZ*")="" D ^PRCFQ
D DQ
K PRCF,PRCF("TDATE"),PRCFA Q
;
DQ I $D(ZTQUEUED) D:0 KILL^%ZTLOAD S ZTREQ="@" ; REW ? for Patch 97
;D:$D(ZTQUEUED) KILL^%ZTLOAD ; original line
S X="BATCH/TRANSMIT" D LOCK^PRCFALCK Q:'%
K ^TMP("PRCB",$J,"BCS"),^TMP("PRCB",$J,"TRDA")
S DA=0 F I=1:1 S DA=$O(^PRCF(421,"AL",PRCF("SIFY"),2,DA)) Q:'DA D ADD
;D DA=0:0 S DA=$O(^TMP("PRCB",$J,"TRDA",DA)) Q:'DA I $D(^PRCF(421,DA,0)) S $P(^(4),"^",PRC("QTR"))=1
;K ^TMP("PRCB",$J,"TRDA")
S PRC("FYF")=0 F S PRC("FYF")=$O(^TMP("PRCB",$J,"BCS",PRC("SITE"),PRC("FYF"))) Q:'PRC("FYF") S AMT=+^(PRC("FYF")),X="",PRCFID="" D:AMT'=0 D EPRN
. N A,B
. S PRC("CP")=$P(PRC("FYF"),"~"),PRC("BBFY")=$P(PRC("FYF"),"~",2),PRC("CPT")=$P(PRC("FYF"),"~",3)
. S PRC("FC")=PRCF("TDATE")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_PRC("SITE")_"^"_PRC("CP")_"^"_AMT_"^"_PRC("BBFY")_"^"_PRC("CPT"),PRC("AMT")=AMT
. S $P(PRC("FC"),"^",9)=PRCF("ACCTF")
. I PRC("CPT")="" D SA^PRCB8A(.X,PRC("FC")) S PRCFID=$P(X,"^",2) QUIT
. S PRCA=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
. S PRCB=$$ACC^PRC0C(PRC("SITE"),PRC("CPT")_"^"_PRC("FY")_"^"_PRC("BBFY"))
. I $P(PRCA,"^",9)=$P(PRCB,"^",9)&($P(PRCA,"^",2)=$P(PRCB,"^",2)) D QUIT
.. S C=$$FMSACC^PRC0D(PRC("SITE"),PRCA),C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
.. I 'C S $P(PRC("FC"),"^",6)=0 D SA^PRCB8A(.X,PRC("FC"))
.. S C=$$FMSACC^PRC0D(PRC("SITE"),PRCB),C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
.. I 'C S $P(PRC("FC"),"^",6)=0 D SA^PRCB8A(.X,$P(PRC("FC"),"^",1,4)_"^"_PRC("CPT")_"^"_$P(PRC("FC"),"^",6,999))
.. S $P(PRC("FC"),"^",6)=-PRC("AMT") D ST^PRCB8A1(.X,PRC("FC")) S PRCFID=$P(X,"^",2)
.. QUIT
. D SA^PRCB8A(.X,PRC("FC"))
. S $P(PRC("FC"),"^",6)=-PRC("AMT") D AT^PRCB8A2(.X,PRC("FC"))
. S PRCFID=$P(X,"^",2),$P(PRC("FC"),"^",5)=PRC("CPT") D SA^PRCB8A(.X,PRC("FC"))
. QUIT
;
;
;S FR="",TO="",IOP=ION,DIC="^PRCF(421,",L=0,BY=$S($G(PRC("PRCOLD")):"[PRCB GENERATE CODE SHEETS]",1:".6,1,.01")
K IOP S (FR,TO)="",DIC="^PRCF(421,",L=0,BY="+1;S2,.01"
S FLDS=".01,1,6,&"_(PRC("QTR")+6),BY(0)="^PRCF(421,""AN"",",L(0)=2
; REW <<<<<<< This code eliminate uses of BY-with-a-template with BY(0) per Forum msg 19270200
;S (FR,TO)=1,IOP=ION,DIC="^PRCF(421,",L=0,BY="NUMBER",FLDS=".01"
DIP ;S:$G(^PRCHREW) ^PRCHREW($H,1)=$G(ZTQUEUED)_U_$J
D EN1^DIP
;S:$G(^PRCHREW) ^PRCHREW($H,2)=$G(ZTSTAT) ; Documenting call to and return from DIP
;
;
BACK K ^TMP("PRCB",$J,"BCS") S X="BATCH/TRANSMIT" D UNLOCK^PRCFALCK
;S:$G(^PRCHREW) ^PRCHREW($H,3)="" ; <<<<< REW Documenting return from UNLOCK
QUIT
;
ERR W !,"Unable to create code sheet for Station: "_PRC("SITE")_", Control Point: "_PRC("CP")_", FY: "_PRC("FY"),", Quarter: "_PRC("QTR")_"." Q
;
EPRN ;set printing flag/FMS id in file 410
N A,B,C
S A="" F S A=$O(^TMP("PRCB",$J,"BCS",PRC("SITE"),PRC("FYF"),A)) Q:'A D
. F C=1,2 S B=$P(A,"~",C) I B,$D(^PRCF(421,B,0)) S $P(^(4),"^",PRC("QTR"))=1,D=$P(^(4),"^",6+PRC("QTR")) S:D $P(^PRCS(410,D,4),"^",5)=PRCFID
. QUIT
QUIT
;
ADD ;ADD AMOUNT INTO SCRATCH GLOBAL
N A
QUIT:'$D(^PRCF(421,DA,0)) S X=^(0) QUIT:'$P(X,"^",23)!+$P($G(^(4)),U,PRC("QTR"))
I +$P(X,U,PRC("QTR")+6)'=0,$P(X,U,20)=2,$P(^PRC(420,PRC("SITE"),1,+$P(X,U,2),0),U,12)<3 D S ^PRCF(421,"AN",1,DA)="",$P(^PRCF(421,DA,0),"^",19)=1
. ;S ^TMP("PRCB",$J,"TRDA",DA)=""
. S Y=+$P(X,"^",2)_"~"_$P($$DATE^PRC0C($P(X,"^",23),"I"),"^",3),AMT=$P(X,"^",PRC("QTR")+6)
. I $P(X,"^",22) QUIT:AMT>0 S $P(Y,"~",3)=+$P($G(^PRCF(421,$P(X,"^",22),0)),"^",2)
. S:'$D(^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)) ^(Y)=0
. S ^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)=^TMP("PRCB",$J,"BCS",PRC("SITE"),Y)+$P(X,"^",PRC("QTR")+6)
. S ^TMP("PRCB",$J,"BCS",PRC("SITE"),Y,DA_"~"_$P(X,"^",22))=""
. QUIT
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBCS 5709 printed Dec 13, 2024@02:00:37 Page 2
PRCBCS ;WISC@ALTOONA/CTB-WIRMFO/REW-CREATE CODE SHEETS FROM RELEASED TRX ; [7/1/98 3:00pm]
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW A,PRCF
+3 KILL ^PRCF(421,"AN"),^TMP("PRCB",$JOB,"BCS"),^TMP("PRCB",$JOB,"TRDA"),^TMP("PRCB",$JOB,"CODE")
SET PRCF("X")="BQ"
DO ^PRCFSITE
if '%
QUIT
+4 SET X=PRC("QTR")
SET X(1)="This option will now generate FMS documents for "_X_$SELECT(X=1:"st",X=2:"nd",X=3:"rd",1:"th")_" Quarter, FY "_PRC("FY")
+5 SET X(2)="released transactions which have not previously been coded."
Q1 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","O",A)
+3 if X["^"!(X="")
QUIT
+4 IF Y#100=0
WRITE " Enter precise date!"
GOTO Q1
+5 SET Y=$$DT^PRC0B2(Y,"I")
+6 WRITE " (",$PIECE(Y,"^",5),")"
+7 ;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
+8 ;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The FMS Transaction Date should be in the entered fiscal year and quarter.") G Q1
+9 SET PRCF("TDATE")=+Y
SET PRCF("ACCTP")=$PIECE($$DT^PRC0B2($EXTRACT(Y,1,5)_"00","I"),"^",5)
Q2 SET Y(1)="Enter a calendar (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",PRCF("ACCTP"))
+3 IF X=""!(X["^")
GOTO Q1
+4 if Y<0
GOTO Q2
+5 IF Y#100'=0
WRITE " Enter month/year only!"
GOTO Q2
+6 SET Y=$$DT^PRC0B2(Y,"I")
+7 WRITE " (",$PIECE(Y,"^",5),")"
+8 ;S A=$$DATE^PRC0C($P(Y,"^",5),"E")
+9 ;I PRC("FY")'=$E(A,3,4)!(PRC("QTR")'=$P(A,"^",2)) D EN^DDIOL("The Accounting Period should be in the entered fiscal year and quarter.") G Q2
+10 SET PRCF("ACCTP")=$PIECE(Y,"^",5)
SET X=$$DATE^PRC0C(+Y,"I")
+11 SET PRCF("ACCTF")=$PIECE(X,"^",9)_$EXTRACT(X,3,4)_"^"_PRCF("ACCTP")
Q9 DO YN^PRC0A(.X,.Y,"Ready to generate FMS documents","O","YES")
+1 if X["^"!(X="")
QUIT
+2 if Y<1
GOTO Q1
+3 ;S ZTDESC="CREATE BUDGET CODE SHEETS",ZTRTN="DQ^PRCBCS",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("DUZ*")="" D ^PRCFQ
+4 DO DQ
+5 KILL PRCF,PRCF("TDATE"),PRCFA
QUIT
+6 ;
DQ ; REW ? for Patch 97
IF $DATA(ZTQUEUED)
if 0
DO KILL^%ZTLOAD
SET ZTREQ="@"
+1 ;D:$D(ZTQUEUED) KILL^%ZTLOAD ; original line
+2 SET X="BATCH/TRANSMIT"
DO LOCK^PRCFALCK
if '%
QUIT
+3 KILL ^TMP("PRCB",$JOB,"BCS"),^TMP("PRCB",$JOB,"TRDA")
+4 SET DA=0
FOR I=1:1
SET DA=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),2,DA))
if 'DA
QUIT
DO ADD
+5 ;D DA=0:0 S DA=$O(^TMP("PRCB",$J,"TRDA",DA)) Q:'DA I $D(^PRCF(421,DA,0)) S $P(^(4),"^",PRC("QTR"))=1
+6 ;K ^TMP("PRCB",$J,"TRDA")
+7 SET PRC("FYF")=0
FOR
SET PRC("FYF")=$ORDER(^TMP("PRCB",$JOB,"BCS",PRC("SITE"),PRC("FYF")))
if 'PRC("FYF")
QUIT
SET AMT=+^(PRC("FYF"))
SET X=""
SET PRCFID=""
if AMT'=0
Begin DoDot:1
+8 NEW A,B
+9 SET PRC("CP")=$PIECE(PRC("FYF"),"~")
SET PRC("BBFY")=$PIECE(PRC("FYF"),"~",2)
SET PRC("CPT")=$PIECE(PRC("FYF"),"~",3)
+10 SET PRC("FC")=PRCF("TDATE")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_PRC("SITE")_"^"_PRC("CP")_"^"_AMT_"^"_PRC("BBFY")_"^"_PRC("CPT")
SET PRC("AMT")=AMT
+11 SET $PIECE(PRC("FC"),"^",9)=PRCF("ACCTF")
+12 IF PRC("CPT")=""
DO SA^PRCB8A(.X,PRC("FC"))
SET PRCFID=$PIECE(X,"^",2)
QUIT
+13 SET PRCA=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+14 SET PRCB=$$ACC^PRC0C(PRC("SITE"),PRC("CPT")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+15 IF $PIECE(PRCA,"^",9)=$PIECE(PRCB,"^",9)&($PIECE(PRCA,"^",2)=$PIECE(PRCB,"^",2))
Begin DoDot:2
+16 SET C=$$FMSACC^PRC0D(PRC("SITE"),PRCA)
SET C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
+17 IF 'C
SET $PIECE(PRC("FC"),"^",6)=0
DO SA^PRCB8A(.X,PRC("FC"))
+18 SET C=$$FMSACC^PRC0D(PRC("SITE"),PRCB)
SET C=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_C_""",",0)
+19 IF 'C
SET $PIECE(PRC("FC"),"^",6)=0
DO SA^PRCB8A(.X,$PIECE(PRC("FC"),"^",1,4)_"^"_PRC("CPT")_"^"_$PIECE(PRC("FC"),"^",6,999))
+20 SET $PIECE(PRC("FC"),"^",6)=-PRC("AMT")
DO ST^PRCB8A1(.X,PRC("FC"))
SET PRCFID=$PIECE(X,"^",2)
+21 QUIT
End DoDot:2
QUIT
+22 DO SA^PRCB8A(.X,PRC("FC"))
+23 SET $PIECE(PRC("FC"),"^",6)=-PRC("AMT")
DO AT^PRCB8A2(.X,PRC("FC"))
+24 SET PRCFID=$PIECE(X,"^",2)
SET $PIECE(PRC("FC"),"^",5)=PRC("CPT")
DO SA^PRCB8A(.X,PRC("FC"))
+25 QUIT
End DoDot:1
DO EPRN
+26 ;
+27 ;
+28 ;S FR="",TO="",IOP=ION,DIC="^PRCF(421,",L=0,BY=$S($G(PRC("PRCOLD")):"[PRCB GENERATE CODE SHEETS]",1:".6,1,.01")
+29 KILL IOP
SET (FR,TO)=""
SET DIC="^PRCF(421,"
SET L=0
SET BY="+1;S2,.01"
+30 SET FLDS=".01,1,6,&"_(PRC("QTR")+6)
SET BY(0)="^PRCF(421,""AN"","
SET L(0)=2
+31 ; REW <<<<<<< This code eliminate uses of BY-with-a-template with BY(0) per Forum msg 19270200
+32 ;S (FR,TO)=1,IOP=ION,DIC="^PRCF(421,",L=0,BY="NUMBER",FLDS=".01"
DIP ;S:$G(^PRCHREW) ^PRCHREW($H,1)=$G(ZTQUEUED)_U_$J
+1 DO EN1^DIP
+2 ;S:$G(^PRCHREW) ^PRCHREW($H,2)=$G(ZTSTAT) ; Documenting call to and return from DIP
+3 ;
+4 ;
BACK KILL ^TMP("PRCB",$JOB,"BCS")
SET X="BATCH/TRANSMIT"
DO UNLOCK^PRCFALCK
+1 ;S:$G(^PRCHREW) ^PRCHREW($H,3)="" ; <<<<< REW Documenting return from UNLOCK
+2 QUIT
+3 ;
ERR WRITE !,"Unable to create code sheet for Station: "_PRC("SITE")_", Control Point: "_PRC("CP")_", FY: "_PRC("FY"),", Quarter: "_PRC("QTR")_"."
QUIT
+1 ;
EPRN ;set printing flag/FMS id in file 410
+1 NEW A,B,C
+2 SET A=""
FOR
SET A=$ORDER(^TMP("PRCB",$JOB,"BCS",PRC("SITE"),PRC("FYF"),A))
if 'A
QUIT
Begin DoDot:1
+3 FOR C=1,2
SET B=$PIECE(A,"~",C)
IF B
IF $DATA(^PRCF(421,B,0))
SET $PIECE(^(4),"^",PRC("QTR"))=1
SET D=$PIECE(^(4),"^",6+PRC("QTR"))
if D
SET $PIECE(^PRCS(410,D,4),"^",5)=PRCFID
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
ADD ;ADD AMOUNT INTO SCRATCH GLOBAL
+1 NEW A
+2 if '$DATA(^PRCF(421,DA,0))
QUIT
SET X=^(0)
if '$PIECE(X,"^",23)!+$PIECE($GET(^(4)),U,PRC("QTR"))
QUIT
+3 IF +$PIECE(X,U,PRC("QTR")+6)'=0
IF $PIECE(X,U,20)=2
IF $PIECE(^PRC(420,PRC("SITE"),1,+$PIECE(X,U,2),0),U,12)<3
Begin DoDot:1
+4 ;S ^TMP("PRCB",$J,"TRDA",DA)=""
+5 SET Y=+$PIECE(X,"^",2)_"~"_$PIECE($$DATE^PRC0C($PIECE(X,"^",23),"I"),"^",3)
SET AMT=$PIECE(X,"^",PRC("QTR")+6)
+6 IF $PIECE(X,"^",22)
if AMT>0
QUIT
SET $PIECE(Y,"~",3)=+$PIECE($GET(^PRCF(421,$PIECE(X,"^",22),0)),"^",2)
+7 if '$DATA(^TMP("PRCB",$JOB,"BCS",PRC("SITE"),Y))
SET ^(Y)=0
+8 SET ^TMP("PRCB",$JOB,"BCS",PRC("SITE"),Y)=^TMP("PRCB",$JOB,"BCS",PRC("SITE"),Y)+$PIECE(X,"^",PRC("QTR")+6)
+9 SET ^TMP("PRCB",$JOB,"BCS",PRC("SITE"),Y,DA_"~"_$PIECE(X,"^",22))=""
+10 QUIT
End DoDot:1
SET ^PRCF(421,"AN",1,DA)=""
SET $PIECE(^PRCF(421,DA,0),"^",19)=1
+11 QUIT
