- 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 23, 2025@18:32:34 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
