PRCSP1 ;WISC/SAW/KMB-C P ACTIVITY PRINTS ;05/05/98 1400
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
OTR ;OBL TRANS
D EN3^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
S DIC="^PRCS(410,",DIC(0)="AEQ",D="D",DIC("A")="Select PURCHASE ORDER/OBLIGATION NO: "
S DIC("S")="I $D(^(4)),$P(^(4),U,5)]"""",$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),""^"",2)=""O"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
D ^PRCSDIC G EXIT:Y<0 S PRCSX=$P(^PRCS(410,+Y,4),U,5) K DIC("S"),DIC("A")
S %=1,%A="Would you like to include 'Comments'" D ^PRCFYN G OTR:(%'["1")&(%'["2")
S FLDS=$S(%=2:"[PRCSOTR]",1:"[PRCSOTR1]"),DHD="OBLIGATION STATUS REPORT",BY="24;S1",(FR,TO)=PRCSX D S K PRC("CP") I $D(^PRC(442,"B",PRC("SITE")_PRCSX)) S D0=$O(^(PRCSX,0)) D POS1^PRCSP1B K PRCSX G OTR
K PRCSX G OTR
TS ;CPC/CPO TRANS STATUS
S PRCSST=1 ; Don't prompt for substation
K PRC("CP") ; Delete control point default
D EN3^PRCSUT K PRCSST
N PRCSX1,PRCSX2
S DIC="^PRCS(410,",DIC(0)="AEMQ"
I $D(PRC("CP"))#10=1 S DIC("S")="I $G(^(3))]"""",+$P(^(3),U,1)=+PRC(""CP"")"
;I $D(PRC("CP"))#10=1 S DIC("S")="I $G(^(3))]"""",$P(^(3),U,1)=PRC(""CP"")"
E S DIC("S")="S PRCSX1=$P(^(0),""^"",5),PRCSX2=$S($D(^(3)):$P(^(3),""^""),1:"""") I $D(^PRC(420,""A"",DUZ,+PRCSX1,+PRCSX2))"
D ^PRCSDIC K PRCSX1,PRCSX2 G EXIT:Y<0 K DIC("S") S DA=+Y D DEV G EXIT:POP I $D(IO("Q")) S ZTRTN="^PRCSP13",ZTSAVE("DA")="" D ^%ZTLOAD,EXIT G TS
D ^PRCSP13,W2 G TS
TSS ;REQ TRANS STATUS
N X3 S X3="H" D W3
S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION NUMBER: ",DIC("S")="I $P(^(0),""^"",3)'="""",$D(^PRCS(410,""H"",$P(^(0),""^"",3),+Y)),^(+Y)=DUZ!(^(+Y)="""")",D="H"
D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A") S DA=+Y D DEV G EXIT:POP I $D(IO("Q")) S ZTRTN="^PRCSP13",ZTSAVE("DA")="" D ^%ZTLOAD,EXIT G TSS
D ^PRCSP13,W2 G TSS
PRNT ;
N X3 S X3=0 D W3 S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H",DIC("S")="I $P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")"
D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S")
S DA=+Y,PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5),PRC("CP")=$P(^(3),"^"),PFLAG=1 G PRF2
CPOQR ;CP OFFICIAL'S QTRLY REPORT
D EN^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0 S PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
S DIOEND="I $D(PRCS(1)),$D(PRCS(2)) W !,""TOTAL COMMITTED, NOT OBLIGATED: $"",$J(PRCS(2)-PRCS(1),0,2) K DIOEND"
S FLDS="[PRCSCPOQR]",DHD="CONTROL POINT QUARTERLY REPORT - "_PRC("CP"),BY="@.01",FR=PRCSAZ_"-0001",TO=PRCSAZ_"-9999" D S
N REPORT2 S REPORT2=1 D T2^PRCSAPP1
K PRC("CP"),PRCS(1),PRCS(2),PRCSAZ G CPOQR
ALLCP ;PRINT REQUEST FROM ANY CP
;
D NSCRN^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
S DISONLY=1 G PRF0
PRF ;PRINT REQUEST FORM
;
D EN3^PRCSUT G W1:'$D(PRC("SITE")),EXIT:Y<0
PRF0 S DIC="^PRCS(410,",DIC(0)="AEMQ",DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,2)=""O""" D ^PRCSDIC G EXIT:Y<0 K DIC("S") S DA=+Y
PRF1 ;
N PFLAG,PRCSQ,TRNODE,CET S PFLAG=0
PRF2 S PRCSQ=$P(^PRCS(410,DA,0),U,4) S TRNODE(0)="",CET=0 D NODE^PRCS58OB(DA,.TRNODE)
PRF3 ;
N PRNTALL
S PRNTALL=0
I PRCSQ=1 G PRF5 ;DON'T ASK 2237 QUESTION IF THIS IS A 1358 . . .
N %
PRF4 ;
S %=1 W !,"Print administrative certification page of 2237"
D YN^DICN
I %=1 S PRNTALL=1
I %=0 W !,"Enter NO to not print administrative certifications,",!," justifications, and data on last page of the 2237",! G PRF4
I %'=1 S PRNTALL=0
I '$D(^PRCS(410,DA,"IT",0)) W !!,"Items have not been entered for this request.",!,"Requests without items are not printed." H 2 G EXIT
PRF5 I '$D(DISONLY) D DEV G EXIT:POP G PRFPRN
S IOP="" D ^%ZIS
;
PRFPRN ;
N PRCPRIB S PRCPRIB=DA
I $D(IO("Q")) K IO("Q") S ZTRTN=$S(PRCSQ=1:"^PRCE58P2",PRCSQ=5:"DQ^PRCPRIB0",1:"^PRCSP12"),ZTSAVE("PRNTALL")="",ZTSAVE("DA")="",ZTSAVE("PRC*")="",ZTSAVE("TRNODE*")="" D ^%ZTLOAD,HOME^%ZIS
I G:$D(PRCSF) EXIT D W2 G:$D(DISONLY) ALLCP G:PFLAG=1 PRNT G PRF
I $E(IOST)="P" S F=$S(PRCSQ=1:"^PRCE58P2",PRCSQ=5:"DQ^PRCPRIB0",1:"^PRCSP12") D @F D ^%ZISC G:$D(PRCSF) EXIT D W2 G:$D(DISONLY) ALLCP G:PFLAG=1 PRNT G PRF
D:PRCSQ=5 DQ^PRCPRIB0 D:PRCSQ=1 ^PRCE58P0 D:PRCSQ'=1&(PRCSQ'=5) ^PRCSD12 W:$Y>0 @IOF G:$D(PRCSF) EXIT D W2 G:$D(DISONLY) ALLCP G:PFLAG=1 PRNT G PRF
;
EN1 S DIC="^PRCS(410,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),""^"",2)=""O"",$D(^(7)),$P(^(7),""^"",6)'=""""",DIC("A")="Select TRANSACTION NUMBER: " D ^PRCSDIC G EXIT:Y<0 S PRCSF=1,DA=+Y D PRF1 K DIC,PRCSF G EN1
S S L=0,DIC="^PRCS(410," D EN1^DIP K IOP,PRCSPOP Q
DEV K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q
W3 W !!,"For the transaction number, use an uppercase alpha as the first character,",!,"and then 2-16 uppercase or numeric characters, as in ADP1.",! Q
W2 W !!,"Enter information for another report or an uparrow to return to the menu.",! Q
W1 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT
W I (IO=IO(0))&('$D(ZTQUEUED)) W !!,"Press return to continue: " R X:DTIME
I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
EXIT K %,%DT,%ZIS,BY,C2,C3,D,DA,DHD,DIC,PRCS,FLDS,FR,I,L,N,TO,X,Y,ZTRTN,ZTSAVE,DISONLY,F
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSP1 5230 printed Apr 09, 2024@21:17:59 Page 2
PRCSP1 ;WISC/SAW/KMB-C P ACTIVITY PRINTS ;05/05/98 1400
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
OTR ;OBL TRANS
+1 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W1
if Y<0
GOTO EXIT
+2 SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET D="D"
SET DIC("A")="Select PURCHASE ORDER/OBLIGATION NO: "
+3 SET DIC("S")="I $D(^(4)),$P(^(4),U,5)]"""",$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),""^"",2)=""O"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
+4 DO ^PRCSDIC
if Y<0
GOTO EXIT
SET PRCSX=$PIECE(^PRCS(410,+Y,4),U,5)
KILL DIC("S"),DIC("A")
+5 SET %=1
SET %A="Would you like to include 'Comments'"
DO ^PRCFYN
if (%'["1")&(%'["2")
GOTO OTR
+6 SET FLDS=$SELECT(%=2:"[PRCSOTR]",1:"[PRCSOTR1]")
SET DHD="OBLIGATION STATUS REPORT"
SET BY="24;S1"
SET (FR,TO)=PRCSX
DO S
KILL PRC("CP")
IF $DATA(^PRC(442,"B",PRC("SITE")_PRCSX))
SET D0=$ORDER(^(PRCSX,0))
DO POS1^PRCSP1B
KILL PRCSX
GOTO OTR
+7 KILL PRCSX
GOTO OTR
TS ;CPC/CPO TRANS STATUS
+1 ; Don't prompt for substation
SET PRCSST=1
+2 ; Delete control point default
KILL PRC("CP")
+3 DO EN3^PRCSUT
KILL PRCSST
+4 NEW PRCSX1,PRCSX2
+5 SET DIC="^PRCS(410,"
SET DIC(0)="AEMQ"
+6 IF $DATA(PRC("CP"))#10=1
SET DIC("S")="I $G(^(3))]"""",+$P(^(3),U,1)=+PRC(""CP"")"
+7 ;I $D(PRC("CP"))#10=1 S DIC("S")="I $G(^(3))]"""",$P(^(3),U,1)=PRC(""CP"")"
+8 IF '$TEST
SET DIC("S")="S PRCSX1=$P(^(0),""^"",5),PRCSX2=$S($D(^(3)):$P(^(3),""^""),1:"""") I $D(^PRC(420,""A"",DUZ,+PRCSX1,+PRCSX2))"
+9 DO ^PRCSDIC
KILL PRCSX1,PRCSX2
if Y<0
GOTO EXIT
KILL DIC("S")
SET DA=+Y
DO DEV
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTRTN="^PRCSP13"
SET ZTSAVE("DA")=""
DO ^%ZTLOAD
DO EXIT
GOTO TS
+10 DO ^PRCSP13
DO W2
GOTO TS
TSS ;REQ TRANS STATUS
+1 NEW X3
SET X3="H"
DO W3
+2 SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET DIC("A")="Select TRANSACTION NUMBER: "
SET DIC("S")="I $P(^(0),""^"",3)'="""",$D(^PRCS(410,""H"",$P(^(0),""^"",3),+Y)),^(+Y)=DUZ!(^(+Y)="""")"
SET D="H"
+3 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("S"),DIC("A")
SET DA=+Y
DO DEV
if POP
GOTO EXIT
IF $DATA(IO("Q"))
SET ZTRTN="^PRCSP13"
SET ZTSAVE("DA")=""
DO ^%ZTLOAD
DO EXIT
GOTO TSS
+4 DO ^PRCSP13
DO W2
GOTO TSS
PRNT ;
+1 NEW X3
SET X3=0
DO W3
SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET DIC("A")="Select TRANSACTION: "
SET D="H"
SET DIC("S")="I $P(^(0),U,3)'="""",$D(^PRCS(410,""H"",$P(^(0),U,3),+Y)),^(+Y)=DUZ!(^(+Y)="""")"
+2 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("A"),DIC("S")
+3 SET DA=+Y
SET PRC("SITE")=+$PIECE(^PRCS(410,DA,0),"^",5)
SET PRC("CP")=$PIECE(^(3),"^")
SET PFLAG=1
GOTO PRF2
CPOQR ;CP OFFICIAL'S QTRLY REPORT
+1 DO EN^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W1
if Y<0
GOTO EXIT
SET PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+2 SET DIOEND="I $D(PRCS(1)),$D(PRCS(2)) W !,""TOTAL COMMITTED, NOT OBLIGATED: $"",$J(PRCS(2)-PRCS(1),0,2) K DIOEND"
+3 SET FLDS="[PRCSCPOQR]"
SET DHD="CONTROL POINT QUARTERLY REPORT - "_PRC("CP")
SET BY="@.01"
SET FR=PRCSAZ_"-0001"
SET TO=PRCSAZ_"-9999"
DO S
+4 NEW REPORT2
SET REPORT2=1
DO T2^PRCSAPP1
+5 KILL PRC("CP"),PRCS(1),PRCS(2),PRCSAZ
GOTO CPOQR
ALLCP ;PRINT REQUEST FROM ANY CP
+1 ;
+2 DO NSCRN^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W1
if Y<0
GOTO EXIT
+3 SET DISONLY=1
GOTO PRF0
PRF ;PRINT REQUEST FORM
+1 ;
+2 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))
GOTO W1
if Y<0
GOTO EXIT
PRF0 SET DIC="^PRCS(410,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,2)=""O"""
DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("S")
SET DA=+Y
PRF1 ;
+1 NEW PFLAG,PRCSQ,TRNODE,CET
SET PFLAG=0
PRF2 SET PRCSQ=$PIECE(^PRCS(410,DA,0),U,4)
SET TRNODE(0)=""
SET CET=0
DO NODE^PRCS58OB(DA,.TRNODE)
PRF3 ;
+1 NEW PRNTALL
+2 SET PRNTALL=0
+3 ;DON'T ASK 2237 QUESTION IF THIS IS A 1358 . . .
IF PRCSQ=1
GOTO PRF5
+4 NEW %
PRF4 ;
+1 SET %=1
WRITE !,"Print administrative certification page of 2237"
+2 DO YN^DICN
+3 IF %=1
SET PRNTALL=1
+4 IF %=0
WRITE !,"Enter NO to not print administrative certifications,",!," justifications, and data on last page of the 2237",!
GOTO PRF4
+5 IF %'=1
SET PRNTALL=0
+6 IF '$DATA(^PRCS(410,DA,"IT",0))
WRITE !!,"Items have not been entered for this request.",!,"Requests without items are not printed."
HANG 2
GOTO EXIT
PRF5 IF '$DATA(DISONLY)
DO DEV
if POP
GOTO EXIT
GOTO PRFPRN
+1 SET IOP=""
DO ^%ZIS
+2 ;
PRFPRN ;
+1 NEW PRCPRIB
SET PRCPRIB=DA
+2 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN=$SELECT(PRCSQ=1:"^PRCE58P2",PRCSQ=5:"DQ^PRCPRIB0",1:"^PRCSP12")
SET ZTSAVE("PRNTALL")=""
SET ZTSAVE("DA")=""
SET ZTSAVE("PRC*")=""
SET ZTSAVE("TRNODE*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
+3 IF $TEST
if $DATA(PRCSF)
GOTO EXIT
DO W2
if $DATA(DISONLY)
GOTO ALLCP
if PFLAG=1
GOTO PRNT
GOTO PRF
+4 IF $EXTRACT(IOST)="P"
SET F=$SELECT(PRCSQ=1:"^PRCE58P2",PRCSQ=5:"DQ^PRCPRIB0",1:"^PRCSP12")
DO @F
DO ^%ZISC
if $DATA(PRCSF)
GOTO EXIT
DO W2
if $DATA(DISONLY)
GOTO ALLCP
if PFLAG=1
GOTO PRNT
GOTO PRF
+5 if PRCSQ=5
DO DQ^PRCPRIB0
if PRCSQ=1
DO ^PRCE58P0
if PRCSQ'=1&(PRCSQ'=5)
DO ^PRCSD12
if $Y>0
WRITE @IOF
if $DATA(PRCSF)
GOTO EXIT
DO W2
if $DATA(DISONLY)
GOTO ALLCP
if PFLAG=1
GOTO PRNT
GOTO PRF
+6 ;
EN1 SET DIC="^PRCS(410,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),""^"",2)=""O"",$D(^(7)),$P(^(7),""^"",6)'="""""
SET DIC("A")="Select TRANSACTION NUMBER: "
DO ^PRCSDIC
if Y<0
GOTO EXIT
SET PRCSF=1
SET DA=+Y
DO PRF1
KILL DIC,PRCSF
GOTO EN1
S SET L=0
SET DIC="^PRCS(410,"
DO EN1^DIP
KILL IOP,PRCSPOP
QUIT
DEV KILL IO("Q")
SET %ZIS("B")="HOME"
SET %ZIS="MQ"
DO ^%ZIS
QUIT
W3 WRITE !!,"For the transaction number, use an uppercase alpha as the first character,",!,"and then 2-16 uppercase or numeric characters, as in ADP1.",!
QUIT
W2 WRITE !!,"Enter information for another report or an uparrow to return to the menu.",!
QUIT
W1 WRITE !!,"You are not an authorized control point user.",!,"Contact your control point official."
READ X:5
GOTO EXIT
W IF (IO=IO(0))&('$DATA(ZTQUEUED))
WRITE !!,"Press return to continue: "
READ X:DTIME
+1 Press return to continue: IF (IO'=IO(0))!($DATA(ZTQUEUED))
DO ^%ZISC
EXIT KILL %,%DT,%ZIS,BY,C2,C3,D,DA,DHD,DIC,PRCS,FLDS,FR,I,L,N,TO,X,Y,ZTRTN,ZTSAVE,DISONLY,F
+1 QUIT
