PRCSP1A ;WISC/SAW/BGJ-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;5/1/92 9:20 AM [2/18/99 9:02am]
V ;;5.1;IFCAP;**90,145**;Oct 20, 2000;Build 3
;Per VHA Directive 10-93-142, this routine should not be modified.
CPB ;CP BAL
N PRCSST
S PRCSST=1 D EN1^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCSZ=Z
CPB1 K C1 W !,"Summary Balances Report Only" S %=2 D YN^DICN G EXIT:%<0,CPB1:%=0 S:%=1 C1=1
D DEV1 G EXIT:POP I $D(IO("Q")) S ZTRTN="QUE^PRCSP1A",ZTDESC="RUNNING BALANCE REPORT",ZTSAVE("PRC*")="" S:$D(C1) ZTSAVE("C1")="" D ^%ZTLOAD D ^%ZISC D W1 G EXIT:%'=1 W !! G CPB
D QUE D ^%ZISC D W1 G EXIT:%'=1 K C1 W !! G CPB
QUE ;
N PRCC,PRCD,PRCE
N A,B
S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",1)
U IO S Z1="",P=0 D NOW^%DTC S Y=% D DD^%DT S TDATE=Y,PRCS("A")=1 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",11)="Y" S PRCS("A")=1
S PRCC=$P($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7)
S PRCC=PRCC_"-"_PRC("SITE")_"-"_$P(PRC("CP")," ")_"-",PRCD=PRCC_"~"
S (N,Z,Z(0))=PRCSZ,Z(0)=Z(0)_"-",(PRCS("O"),PRCS("C"))=0,N(1)="" D:'$D(C1) HDR D:$D(C1) HDR2
I $G(C1)=1 W !,"STATION: ",PRC("SITE")," FUND CONTROL POINT: ",PRC("CP"),!,?5,"FISCAL YEAR: ",PRC("FY")," QTR: ",PRC("QTR")
F S PRCC=$O(^PRCS(410,"RB",PRCC)),N(1)=0 QUIT:PRCC]PRCD!'PRCC D
. F S N(1)=$O(^PRCS(410,"RB",PRCC,N(1))),J=" " QUIT:'N(1) D
.. S:'PRCS("A") J=$S($D(^PRCS(410,N(1),7)):$P(^PRCS(410,N(1),7),"^",6),1:"")
.. I J'=""!($P(^PRCS(410,N(1),0),"^",2)'="O"),$P(^(0),"^",2)]"" D TOT
Q:Z1=U D CRT:$E(IOST,1,2)="C-" QUIT:Z1=U D ^PRCSFMS Q:Z1=U
D:IOSL-$Y<8 HOLD Q:Z1=U
W !!!,"Balance Summary",?20,$J("1st Quarter",15),$J("2nd Quarter",15),$J("3rd Quarter",15),$J("4th Quarter",15)
S PRCC=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),2)
S PRCD=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1)
W !!,"Actual CP Bal:",?20 F A=1:1:4 W $J($P(PRCC,"^",A),15,2)
W !,"Actual Fiscal Bal:",?20 F A=1:1:4 W $J($P(PRCD,"^",A),15,2)
W !,"Tot Commit, not Obl:",?20 F A=1:1:4 W $J($J($P(PRCD,"^",A),0,2)-$J($P(PRCC,"^",A),0,2),15,2)
I $J(PRCS("C"),0,2)-$J($P(PRCC,"^",PRC("QTR")),0,2)!($J(PRCS("O"),0,2)-$J($P(PRCD,"^",PRC("QTR")),0,2)) W ! D EN^DDIOL("Report balances do not agree with actual balances. Please recalculate"),EN^DDIOL("your control point.")
W !!,"SECTION 1 CODES # - cancelled order * - order not obligated or signed",!,?17,"@ - purchase card order for reconciliation",!,?17,"& - reconciled order with final charge - ready for approval",!,?17,"R - total reconciled charges"
W !,"SECTION 2 CODES",!,?17,"@ - purchase card CC transaction is not reconciled",!
W !,"The symbols '*','@', and '&' indicate incomplete items.",!,"Please take the necessary steps to clear these items."
D EXIT D:$D(ZTSK) KILL^%ZTLOAD Q
TOT N PRCA,PRCB,PRCG,PRCF,PRCH,PRCJ,PRCK
S T="" S:$D(^PRCS(410,N(1),4)) T=^(4) S X=^(0),Z=$P(X,"^",2),T(0)=$P(T,"^",5),T(1)=$J($P(T,"^",8),0,2),T(3)=$P(T,"^",14),T=$J($P(T,"^",3),0,2),PRCA=$G(^(4)),PRCB=$G(^(7)),PRCH="*^*"
I $P($G(^PRCS(410,N(1),1)),"^",2)=9999999 S PRCH=""
S PRCF=$G(^PRCS(410,N(1),0)),PRCG=$P(PRCF,"^",2),PRCK=$P(PRCF,"^"),PRCF=$P(PRCF,"^",4),PRCK=$P(PRCK,"-",2)_$P(PRCK,"-",3)_$P(PRCK,"-",5)
I PRCG="A",PRCF=1 S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-T(1),$P(PRCH,"^")="" S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-T,$P(PRCH,"^",2)="" Q:$D(C1) G WRT
I PRCG="O" S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-T(1),$P(PRCH,"^")="" S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-T,$P(PRCH,"^",2)=""
I PRCG="C" S PRCH="",PRCS("C")=PRCS("C")+T(1),PRCS("O")=PRCS("O")+T
I PRCG="A" S PRCH="",PRCS("C")=PRCS("C")-T(1) S:T(3)'="Y" PRCS("O")=PRCS("O")-T
I PRCG="CA" S PRCH="#^#"
S PRCJ=$P($G(^PRCS(410,N(1),4)),"^",5)
I PRCH'["#",PRCJ'="" S PRCJ=$P(^PRCS(410,N(1),0),"-")_"-"_PRCJ,PRCJ=$O(^PRC(442,"B",PRCJ,0)) I +PRCJ'=0,$P($G(^PRC(442,PRCJ,0)),"^",2)=25 S X=$G(^(7)) D
. S:PRCG'="A" PRCH="@" S:$P($G(X),"^",2)=40!($P($G(X),"^",2)=41) PRCH="^" S:$P($G(X),"^",2)=50!($P($G(X),"^",2)=51) PRCH="&"
. S T=$P($$FP^PRCH0A(+PRCJ),U,2),$P(PRCH,"^",2)="R"
. QUIT
QUIT:$D(C1)
WRT Q:Z1=U D:IOSL-$Y<8 HOLD Q:Z1=U S X1=$S(Z="O":"OBLIGATION",Z="A":"ADJUSTMENT",Z="CA":"CANCELLED",1:"CEILING")
I $P($G(^PRCS(410,N(1),0)),"^",4)=5 S X1="ISSUE BOOK"
S PZIP=$P($P(X,"^"),"-",5),PZIP=$E(PZIP,1,4)
W !,PRCK,?8,$E(X1,1,3),?12,T(0)
S Y=$P($G(^PRCS(410,N(1),4)),"^",4) S:Y="" Y=$P($G(^PRCS(410,N(1),7)),"^",5) I Y'="" W ?26,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
W ?36,$J(T(1),10,2),$P(PRCH,"^")
W ?47,$J(PRCS("C"),10,2) I T'="",T(3)'="Y" W ?58,$J(T,10,2),$P(PRCH,"^",2)
W ?69,$J(PRCS("O"),10,2) Q
HDR S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P
W !!,?69,"FISCAL"
W !,"FYQSeq# TXN OBL #",?26,"AP/OB DT",?37,"COMM $AMT",?50,"CP $BAL",?60,"OBL $AMT",?69,"UNOBL $BAL"
S L="",$P(L,"-",IOM)="-" W !,L S L="" Q
HDR2 S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P,! Q
HOLD G HDR:$E(IOST,1,2)'="C-"
CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)&('$D(C1))) D HDR
Q
CTR ;CEILING TRANS
D EN^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
S FLDS="[PRCSCTR]",DHD="CEILING REPORT - CP: "_PRC("CP"),BY="@.01,@1",FR=PRCSAZ_"-0001,C",TO=PRCSAZ_"-9999,C" D S
N REPORT2 S REPORT2=1 D T2^PRCSAPP1 K PRC("CP"),PRCSAZ G CTR
ITEMH ;EP;Entry Point for Control Point ITEM HISTORY ; AAC/JDM 10-12-97 - ADDED LINES 66-67 & 69-80 FOR E3R #3344
;EN3^PRCSUT Gets the SITE & Prompts for CONTROL POINT
;DODIP Runs EN1^DIP to list history to selected device
D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S D0=+Y
S CTL=$P(Y,U,2),(FR1,TO1)=CTL
;
; CHOOSE OLD WAY ( LAST 5 ) OR NEW WAY ( DATE RANGE )
K DIR
S DIR(0)="S^L:Last 5 Purchase Orders;D:Date Range"
S DIR("A")="Select ITEM HISTORY Viewing Method"
S DIR("B")="L"
D ^DIR
G:$D(DIRUT) EXIT
W !
G:Y="L" ITEMH1
;
; FALL THROUGH TO DATE RANGE DISPLAY
;
ITEMH0 ; VIEW HISTORY BY DATE RANGE
;
S DIC="^PRC(441,",DIC(0)="AEMNQZ" D ^DIC G EXIT:Y<0
S (FR2,TO2)=$P(Y,U,1)
K DIR S DIR(0)="D",DIR("A")="DATE ORDERED (BEGIN RANGE) ",DIR("B")="T-30" D ^DIR G:$D(DIRUT) EXIT
D ^%DT S FR3=Y
K DIR S DIR(0)="D",DIR("A")="DATE ORDERED (END RANGE) ",DIR("B")="T" D ^DIR G:$D(DIRUT) EXIT
D ^%DT S TO3=Y
D DODIP
G ITEMH
;
ITEMH1 S DIC="^PRC(441,",DIC(0)="AEMNQZ" D ^DIC G EXIT:Y<0 S D0=+Y
D DEV G EXIT:POP
;
ITEMH2 W @IOF S X=D0 D ITEM0^PRCSES1 I $D(ZTSK) D KILL^%ZTLOAD G EXIT
W3 D:$E(IOST,1,2)="C-" W W !!,"Would you like to look at another Item History" S %=2 D YN^DICN G W3:%=0,EXIT:%=2!(%<0) G ITEMH
S S L=0,DIC="^PRCS(410,"
D EN1^DIP Q
;
DEV K IO("Q") S IOP="HOME" D ^%ZIS Q
;
DEV1 K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q
;
W1 K YY S YY(1)="Would you like to run another running balances report",YY(1,"F")="!!" D EN^DDIOL(.YY)
S %=2 D YN^DICN G W1:%=0 Q
W2 K YY S YY(1)="You are not an authorized control point user.",YY(1,"F")="!!",YY(2)="Contact your control point official.",YY(2,"F")="!" D EN^DDIOL(.YY)
K DIR S DIR(0)="E" D ^DIR G EXIT
W4 K YY S YY(1)="Enter information for another report or '^' to return to the menu.",YY(1,"F")="!!" D EN^DDIOL(.YY) Q
W I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
I $E(IOST,1,2)'="C-" D ^%ZISC U IO
;
EXIT K PUR,TDATE,REPORT2,%,%IS,%DT,BY,C0,C2,C3,D,D0,DA,DHD,DIC,DIE,P
K PRCSZ,PRCS,FLDS,FR,I,L,N,T,TO,X,X1,Y,Z,Z1,PZIP,ZTRTN,ZTSAVE Q
K C,CTL,DIR,DTOUT,DUOUT,DIROUT,DIRUT,FR1,FR2,FR3,PRC,PRCSIP,TO1,TO2,TO3,AA,YY
Q
WRITMD ;EP0; WRITES ITEM SHORT DESCRIPTION ON HISTORY HEADER
W $P(^PRC(441,FR2,0),U,2)
Q
WRITMN ;EP; WRITES ITEM NUMBER
W $P(^PRC(441,FR2,0),U,1)
Q
DODIP ; EP ;FOR RTNS CALLING FOR CP ITEM HIST
; AAC/JDM 11/12/97 - THIS SECTION ADDED FOR E3R #3344
; PRCSPGQ is page variable
; PRCSDT is Date/Time in DEC 11, 1998@8:35 format
;
S PRCSPGQ=0
D NOW^%DTC
S Y=$J(%,7,4)
D DD^%DT
S PRCSDT=Y
S FLDS="[PRCS CP ITEMHIST]",BY="[PRCS CP ITEMHIST]",L=0,DIC="^PRCS(410,"
S FR=FR1_","_FR2_","_FR3
S TO=TO1_","_TO2_","_TO3
D EN1^DIP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1A 8136 printed Apr 09, 2024@21:05:11 Page 2
PRCSP1A ;WISC/SAW/BGJ-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;5/1/92 9:20 AM [2/18/99 9:02am]
V ;;5.1;IFCAP;**90,145**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
CPB ;CP BAL
+1 NEW PRCSST
+2 SET PRCSST=1
DO EN1^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
SET PRCSZ=Z
CPB1 KILL C1
WRITE !,"Summary Balances Report Only"
SET %=2
DO YN^DICN
if %<0
GOTO EXIT
if %=0
GOTO CPB1
if %=1
SET C1=1
+1 DO DEV1
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTRTN="QUE^PRCSP1A"
SET ZTDESC="RUNNING BALANCE REPORT"
SET ZTSAVE("PRC*")=""
if $DATA(C1)
SET ZTSAVE("C1")=""
DO ^%ZTLOAD
DO ^%ZISC
DO W1
if %'=1
GOTO EXIT
WRITE !!
GOTO CPB
+2 DO QUE
DO ^%ZISC
DO W1
if %'=1
GOTO EXIT
KILL C1
WRITE !!
GOTO CPB
QUE ;
+1 NEW PRCC,PRCD,PRCE
+2 NEW A,B
+3 SET PRC("CP")=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",1)
+4 USE IO
SET Z1=""
SET P=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TDATE=Y
SET PRCS("A")=1
IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
IF $PIECE(^(0),"^",11)="Y"
SET PRCS("A")=1
+5 SET PRCC=$PIECE($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7)
+6 SET PRCC=PRCC_"-"_PRC("SITE")_"-"_$PIECE(PRC("CP")," ")_"-"
SET PRCD=PRCC_"~"
+7 SET (N,Z,Z(0))=PRCSZ
SET Z(0)=Z(0)_"-"
SET (PRCS("O"),PRCS("C"))=0
SET N(1)=""
if '$DATA(C1)
DO HDR
if $DATA(C1)
DO HDR2
+8 IF $GET(C1)=1
WRITE !,"STATION: ",PRC("SITE")," FUND CONTROL POINT: ",PRC("CP"),!,?5,"FISCAL YEAR: ",PRC("FY")," QTR: ",PRC("QTR")
+9 FOR
SET PRCC=$ORDER(^PRCS(410,"RB",PRCC))
SET N(1)=0
if PRCC]PRCD!'PRCC
QUIT
Begin DoDot:1
+10 FOR
SET N(1)=$ORDER(^PRCS(410,"RB",PRCC,N(1)))
SET J=" "
if 'N(1)
QUIT
Begin DoDot:2
+11 if 'PRCS("A")
SET J=$SELECT($DATA(^PRCS(410,N(1),7)):$PIECE(^PRCS(410,N(1),7),"^",6),1:"")
+12 IF J'=""!($PIECE(^PRCS(410,N(1),0),"^",2)'="O")
IF $PIECE(^(0),"^",2)]""
DO TOT
End DoDot:2
End DoDot:1
+13 if Z1=U
QUIT
if $EXTRACT(IOST,1,2)="C-"
DO CRT
if Z1=U
QUIT
DO ^PRCSFMS
if Z1=U
QUIT
+14 if IOSL-$Y<8
DO HOLD
if Z1=U
QUIT
+15 WRITE !!!,"Balance Summary",?20,$JUSTIFY("1st Quarter",15),$JUSTIFY("2nd Quarter",15),$JUSTIFY("3rd Quarter",15),$JUSTIFY("4th Quarter",15)
+16 SET PRCC=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),2)
+17 SET PRCD=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1)
+18 WRITE !!,"Actual CP Bal:",?20
FOR A=1:1:4
WRITE $JUSTIFY($PIECE(PRCC,"^",A),15,2)
+19 WRITE !,"Actual Fiscal Bal:",?20
FOR A=1:1:4
WRITE $JUSTIFY($PIECE(PRCD,"^",A),15,2)
+20 WRITE !,"Tot Commit, not Obl:",?20
FOR A=1:1:4
WRITE $JUSTIFY($JUSTIFY($PIECE(PRCD,"^",A),0,2)-$JUSTIFY($PIECE(PRCC,"^",A),0,2),15,2)
+21 IF $JUSTIFY(PRCS("C"),0,2)-$JUSTIFY($PIECE(PRCC,"^",PRC("QTR")),0,2)!($JUSTIFY(PRCS("O"),0,2)-$JUSTIFY($PIECE(PRCD,"^",PRC("QTR")),0,2))
WRITE !
DO EN^DDIOL("Report balances do not agree with actual balances. Please recalculate")
DO EN^DDIOL("your control point.")
+22 WRITE !!,"SECTION 1 CODES # - cancelled order * - order not obligated or signed",!,?17,"@ - purchase card order for reconciliation",!,?17,"& - reconciled order with final charge - ready for approval",!,?17,"R - total reconciled charges"
+23 WRITE !,"SECTION 2 CODES",!,?17,"@ - purchase card CC transaction is not reconciled",!
+24 WRITE !,"The symbols '*','@', and '&' indicate incomplete items.",!,"Please take the necessary steps to clear these items."
+25 DO EXIT
if $DATA(ZTSK)
DO KILL^%ZTLOAD
QUIT
TOT NEW PRCA,PRCB,PRCG,PRCF,PRCH,PRCJ,PRCK
+1 SET T=""
if $DATA(^PRCS(410,N(1),4))
SET T=^(4)
SET X=^(0)
SET Z=$PIECE(X,"^",2)
SET T(0)=$PIECE(T,"^",5)
SET T(1)=$JUSTIFY($PIECE(T,"^",8),0,2)
SET T(3)=$PIECE(T,"^",14)
SET T=$JUSTIFY($PIECE(T,"^",3),0,2)
SET PRCA=$GET(^(4))
SET PRCB=$GET(^(7))
SET PRCH="*^*"
+2 IF $PIECE($GET(^PRCS(410,N(1),1)),"^",2)=9999999
SET PRCH=""
+3 SET PRCF=$GET(^PRCS(410,N(1),0))
SET PRCG=$PIECE(PRCF,"^",2)
SET PRCK=$PIECE(PRCF,"^")
SET PRCF=$PIECE(PRCF,"^",4)
SET PRCK=$PIECE(PRCK,"-",2)_$PIECE(PRCK,"-",3)_$PIECE(PRCK,"-",5)
+4 IF PRCG="A"
IF PRCF=1
if $PIECE(PRCB,"^",6)]""
SET PRCS("C")=PRCS("C")-T(1)
SET $PIECE(PRCH,"^")=""
if $PIECE(PRCA,"^",10)]""
SET PRCS("O")=PRCS("O")-T
SET $PIECE(PRCH,"^",2)=""
if $DATA(C1)
QUIT
GOTO WRT
+5 IF PRCG="O"
if $PIECE(PRCB,"^",6)]""
SET PRCS("C")=PRCS("C")-T(1)
SET $PIECE(PRCH,"^")=""
if $PIECE(PRCA,"^",10)]""
SET PRCS("O")=PRCS("O")-T
SET $PIECE(PRCH,"^",2)=""
+6 IF PRCG="C"
SET PRCH=""
SET PRCS("C")=PRCS("C")+T(1)
SET PRCS("O")=PRCS("O")+T
+7 IF PRCG="A"
SET PRCH=""
SET PRCS("C")=PRCS("C")-T(1)
if T(3)'="Y"
SET PRCS("O")=PRCS("O")-T
+8 IF PRCG="CA"
SET PRCH="#^#"
+9 SET PRCJ=$PIECE($GET(^PRCS(410,N(1),4)),"^",5)
+10 IF PRCH'["#"
IF PRCJ'=""
SET PRCJ=$PIECE(^PRCS(410,N(1),0),"-")_"-"_PRCJ
SET PRCJ=$ORDER(^PRC(442,"B",PRCJ,0))
IF +PRCJ'=0
IF $PIECE($GET(^PRC(442,PRCJ,0)),"^",2)=25
SET X=$GET(^(7))
Begin DoDot:1
+11 if PRCG'="A"
SET PRCH="@"
if $PIECE($GET(X),"^",2)=40!($PIECE($GET(X),"^",2)=41)
SET PRCH="^"
if $PIECE($GET(X),"^",2)=50!($PIECE($GET(X),"^",2)=51)
SET PRCH="&"
+12 SET T=$PIECE($$FP^PRCH0A(+PRCJ),U,2)
SET $PIECE(PRCH,"^",2)="R"
+13 QUIT
End DoDot:1
+14 if $DATA(C1)
QUIT
WRT if Z1=U
QUIT
if IOSL-$Y<8
DO HOLD
if Z1=U
QUIT
SET X1=$SELECT(Z="O":"OBLIGATION",Z="A":"ADJUSTMENT",Z="CA":"CANCELLED",1:"CEILING")
+1 IF $PIECE($GET(^PRCS(410,N(1),0)),"^",4)=5
SET X1="ISSUE BOOK"
+2 SET PZIP=$PIECE($PIECE(X,"^"),"-",5)
SET PZIP=$EXTRACT(PZIP,1,4)
+3 WRITE !,PRCK,?8,$EXTRACT(X1,1,3),?12,T(0)
+4 SET Y=$PIECE($GET(^PRCS(410,N(1),4)),"^",4)
if Y=""
SET Y=$PIECE($GET(^PRCS(410,N(1),7)),"^",5)
IF Y'=""
WRITE ?26,$EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+5 WRITE ?36,$JUSTIFY(T(1),10,2),$PIECE(PRCH,"^")
+6 WRITE ?47,$JUSTIFY(PRCS("C"),10,2)
IF T'=""
IF T(3)'="Y"
WRITE ?58,$JUSTIFY(T,10,2),$PIECE(PRCH,"^",2)
+7 WRITE ?69,$JUSTIFY(PRCS("O"),10,2)
QUIT
HDR SET P=P+1
WRITE @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$PIECE(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P
+1 WRITE !!,?69,"FISCAL"
+2 WRITE !,"FYQSeq# TXN OBL #",?26,"AP/OB DT",?37,"COMM $AMT",?50,"CP $BAL",?60,"OBL $AMT",?69,"UNOBL $BAL"
+3 SET L=""
SET $PIECE(L,"-",IOM)="-"
WRITE !,L
SET L=""
QUIT
HDR2 SET P=P+1
WRITE @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$PIECE(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P,!
QUIT
HOLD if $EXTRACT(IOST,1,2)'="C-"
GOTO HDR
CRT WRITE !,"Press return to continue, uparrow (^) to exit: "
READ Z1:DTIME
if '$TEST
SET Z1=U
IF ((Z1'=U)&('$DATA(C1)))
DO HDR
+1 QUIT
CTR ;CEILING TRANS
+1 DO EN^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
SET PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+2 SET FLDS="[PRCSCTR]"
SET DHD="CEILING REPORT - CP: "_PRC("CP")
SET BY="@.01,@1"
SET FR=PRCSAZ_"-0001,C"
SET TO=PRCSAZ_"-9999,C"
DO S
+3 NEW REPORT2
SET REPORT2=1
DO T2^PRCSAPP1
KILL PRC("CP"),PRCSAZ
GOTO CTR
ITEMH ;EP;Entry Point for Control Point ITEM HISTORY ; AAC/JDM 10-12-97 - ADDED LINES 66-67 & 69-80 FOR E3R #3344
+1 ;EN3^PRCSUT Gets the SITE & Prompts for CONTROL POINT
+2 ;DODIP Runs EN1^DIP to list history to selected device
+3 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W2
if Y<0
GOTO EXIT
SET D0=+Y
+4 SET CTL=$PIECE(Y,U,2)
SET (FR1,TO1)=CTL
+5 ;
+6 ; CHOOSE OLD WAY ( LAST 5 ) OR NEW WAY ( DATE RANGE )
+7 KILL DIR
+8 SET DIR(0)="S^L:Last 5 Purchase Orders;D:Date Range"
+9 SET DIR("A")="Select ITEM HISTORY Viewing Method"
+10 SET DIR("B")="L"
+11 DO ^DIR
+12 if $DATA(DIRUT)
GOTO EXIT
+13 WRITE !
+14 if Y="L"
GOTO ITEMH1
+15 ;
+16 ; FALL THROUGH TO DATE RANGE DISPLAY
+17 ;
ITEMH0 ; VIEW HISTORY BY DATE RANGE
+1 ;
+2 SET DIC="^PRC(441,"
SET DIC(0)="AEMNQZ"
DO ^DIC
if Y<0
GOTO EXIT
+3 SET (FR2,TO2)=$PIECE(Y,U,1)
+4 KILL DIR
SET DIR(0)="D"
SET DIR("A")="DATE ORDERED (BEGIN RANGE) "
SET DIR("B")="T-30"
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
+5 DO ^%DT
SET FR3=Y
+6 KILL DIR
SET DIR(0)="D"
SET DIR("A")="DATE ORDERED (END RANGE) "
SET DIR("B")="T"
DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
+7 DO ^%DT
SET TO3=Y
+8 DO DODIP
+9 GOTO ITEMH
+10 ;
ITEMH1 SET DIC="^PRC(441,"
SET DIC(0)="AEMNQZ"
DO ^DIC
if Y<0
GOTO EXIT
SET D0=+Y
+1 DO DEV
if POP
GOTO EXIT
+2 ;
ITEMH2 WRITE @IOF
SET X=D0
DO ITEM0^PRCSES1
IF $DATA(ZTSK)
DO KILL^%ZTLOAD
GOTO EXIT
W3 if $EXTRACT(IOST,1,2)="C-"
DO W
WRITE !!,"Would you like to look at another Item History"
SET %=2
DO YN^DICN
if %=0
GOTO W3
if %=2!(%<0)
GOTO EXIT
GOTO ITEMH
S SET L=0
SET DIC="^PRCS(410,"
+1 DO EN1^DIP
QUIT
+2 ;
DEV KILL IO("Q")
SET IOP="HOME"
DO ^%ZIS
QUIT
+1 ;
DEV1 KILL IO("Q")
SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
QUIT
+1 ;
W1 KILL YY
SET YY(1)="Would you like to run another running balances report"
SET YY(1,"F")="!!"
DO EN^DDIOL(.YY)
+1 SET %=2
DO YN^DICN
if %=0
GOTO W1
QUIT
W2 KILL YY
SET YY(1)="You are not an authorized control point user."
SET YY(1,"F")="!!"
SET YY(2)="Contact your control point official."
SET YY(2,"F")="!"
DO EN^DDIOL(.YY)
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
GOTO EXIT
W4 KILL YY
SET YY(1)="Enter information for another report or '^' to return to the menu."
SET YY(1,"F")="!!"
DO EN^DDIOL(.YY)
QUIT
W IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
+1 IF $EXTRACT(IOST,1,2)'="C-"
DO ^%ZISC
USE IO
+2 ;
EXIT KILL PUR,TDATE,REPORT2,%,%IS,%DT,BY,C0,C2,C3,D,D0,DA,DHD,DIC,DIE,P
+1 KILL PRCSZ,PRCS,FLDS,FR,I,L,N,T,TO,X,X1,Y,Z,Z1,PZIP,ZTRTN,ZTSAVE
QUIT
+2 KILL C,CTL,DIR,DTOUT,DUOUT,DIROUT,DIRUT,FR1,FR2,FR3,PRC,PRCSIP,TO1,TO2,TO3,AA,YY
+3 QUIT
WRITMD ;EP0; WRITES ITEM SHORT DESCRIPTION ON HISTORY HEADER
+1 WRITE $PIECE(^PRC(441,FR2,0),U,2)
+2 QUIT
WRITMN ;EP; WRITES ITEM NUMBER
+1 WRITE $PIECE(^PRC(441,FR2,0),U,1)
+2 QUIT
DODIP ; EP ;FOR RTNS CALLING FOR CP ITEM HIST
+1 ; AAC/JDM 11/12/97 - THIS SECTION ADDED FOR E3R #3344
+2 ; PRCSPGQ is page variable
+3 ; PRCSDT is Date/Time in DEC 11, 1998@8:35 format
+4 ;
+5 SET PRCSPGQ=0
+6 DO NOW^%DTC
+7 SET Y=$JUSTIFY(%,7,4)
+8 DO DD^%DT
+9 SET PRCSDT=Y
+10 SET FLDS="[PRCS CP ITEMHIST]"
SET BY="[PRCS CP ITEMHIST]"
SET L=0
SET DIC="^PRCS(410,"
+11 SET FR=FR1_","_FR2_","_FR3
+12 SET TO=TO1_","_TO2_","_TO3
+13 DO EN1^DIP
+14 QUIT
