- 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 Feb 18, 2025@23:27:01 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