- 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 Jan 18, 2025@03:19:03 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