PRCPPOU1 ;WISC/RFJ-receive purchase order (utilities) ;06 Jan 94
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
SELECTPO(PRCPINPT) ; select purchase order
N %,C,DIC,I,PRCPORDR,PRCPSCRN,X,Y
S PRCPSCRN="I $D(^PRC(442,""G"",PRCPINPT,+Y)) S %=$P($G(^PRCD(442.3,+$G(^PRC(442,+Y,7)),0)),U,2) I ""^25^26^27^28^30^31^32^33^34^37^38^40^41^46^47^48^49^50^51^""[(""^""_%_""^"")"
F D Q:$G(PRCPORDR)
. W !!,"Select PURCHASE ORDER: "
. R X:DTIME I '$T!(X["^")!(X="") S PRCPORDR=-1 Q
. I X["?" D S PRCPORDR=0 Q
. . S D="G",DIC="^PRC(442,",DIC(0)="QECM",DIC("W")="D DICW^PRCPPOU1",DIC("S")=PRCPSCRN
. . D IX^DIC
. ; lookup po in x
. S DIC="^PRC(442,",DIC(0)="EQMZ",DIC("S")=PRCPSCRN
. D ^DIC I Y<0 S PRCPORDR=0 Q
. S PRCPORDR=+Y
Q PRCPORDR
;
;
PARTIAL(PRCPORDR) ; select partial date
N %,C,DA,DIC,X,Y
I '$D(^PRC(442,PRCPORDR,11,0)) S ^(0)="^442.11D^^"
S DIC="^PRC(442,"_PRCPORDR_",11,",DA(1)=PRCPORDR,DIC(0)="QEAMZ",DIC("S")="I $P(^(0),U,16)="""""
W ! D ^DIC
Q +Y
;
;
DICW ; write id for purchase order lookup
N %,DATA
S DATA=^PRC(442,+Y,0)
W " ",$P(DATA,U)
S %=$P($G(^PRC(442,+Y,1)),"^",15) W:% " ",$E(%,4,5),"-",$E(%,6,7),"-",$E(%,2,3)
S %=$P($G(^PRCD(442.5,+$P(DATA,"^",2),0)),"^") W:%'="" " ",%
S %=$P($G(^PRCD(442.3,+$G(^PRC(442,+Y,7)),0)),"^")
W !?7,$E(%,1,34),?45,"FCP: ",$P($P(DATA,"^",3)," ",1)," $ ",$P(DATA,"^",15)
Q
;
;
LINEITEM(PRCPORDR) ; select line item
N D0,DA,DIC,X,Y
S DIC="^PRC(442,"_PRCPORDR_",2,",(DA(1),D0)=PRCPORDR,DIC(0)="QEAMZ",DIC("S")="I $D(^TMP($J,""PRCPPOLMCOS"",Y))"
W ! D ^DIC
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPPOU1 1689 printed Dec 13, 2024@02:14:28 Page 2
PRCPPOU1 ;WISC/RFJ-receive purchase order (utilities) ;06 Jan 94
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
SELECTPO(PRCPINPT) ; select purchase order
+1 NEW %,C,DIC,I,PRCPORDR,PRCPSCRN,X,Y
+2 SET PRCPSCRN="I $D(^PRC(442,""G"",PRCPINPT,+Y)) S %=$P($G(^PRCD(442.3,+$G(^PRC(442,+Y,7)),0)),U,2) I ""^25^26^27^28^30^31^32^33^34^37^38^40^41^46^47^48^49^50^51^""[(""^""_%_""^"")"
+3 FOR
Begin DoDot:1
+4 WRITE !!,"Select PURCHASE ORDER: "
+5 READ X:DTIME
IF '$TEST!(X["^")!(X="")
SET PRCPORDR=-1
QUIT
+6 IF X["?"
Begin DoDot:2
+7 SET D="G"
SET DIC="^PRC(442,"
SET DIC(0)="QECM"
SET DIC("W")="D DICW^PRCPPOU1"
SET DIC("S")=PRCPSCRN
+8 DO IX^DIC
End DoDot:2
SET PRCPORDR=0
QUIT
+9 ; lookup po in x
+10 SET DIC="^PRC(442,"
SET DIC(0)="EQMZ"
SET DIC("S")=PRCPSCRN
+11 DO ^DIC
IF Y<0
SET PRCPORDR=0
QUIT
+12 SET PRCPORDR=+Y
End DoDot:1
if $GET(PRCPORDR)
QUIT
+13 QUIT PRCPORDR
+14 ;
+15 ;
PARTIAL(PRCPORDR) ; select partial date
+1 NEW %,C,DA,DIC,X,Y
+2 IF '$DATA(^PRC(442,PRCPORDR,11,0))
SET ^(0)="^442.11D^^"
+3 SET DIC="^PRC(442,"_PRCPORDR_",11,"
SET DA(1)=PRCPORDR
SET DIC(0)="QEAMZ"
SET DIC("S")="I $P(^(0),U,16)="""""
+4 WRITE !
DO ^DIC
+5 QUIT +Y
+6 ;
+7 ;
DICW ; write id for purchase order lookup
+1 NEW %,DATA
+2 SET DATA=^PRC(442,+Y,0)
+3 WRITE " ",$PIECE(DATA,U)
+4 SET %=$PIECE($GET(^PRC(442,+Y,1)),"^",15)
if %
WRITE " ",$EXTRACT(%,4,5),"-",$EXTRACT(%,6,7),"-",$EXTRACT(%,2,3)
+5 SET %=$PIECE($GET(^PRCD(442.5,+$PIECE(DATA,"^",2),0)),"^")
if %'=""
WRITE " ",%
+6 SET %=$PIECE($GET(^PRCD(442.3,+$GET(^PRC(442,+Y,7)),0)),"^")
+7 WRITE !?7,$EXTRACT(%,1,34),?45,"FCP: ",$PIECE($PIECE(DATA,"^",3)," ",1)," $ ",$PIECE(DATA,"^",15)
+8 QUIT
+9 ;
+10 ;
LINEITEM(PRCPORDR) ; select line item
+1 NEW D0,DA,DIC,X,Y
+2 SET DIC="^PRC(442,"_PRCPORDR_",2,"
SET (DA(1),D0)=PRCPORDR
SET DIC(0)="QEAMZ"
SET DIC("S")="I $D(^TMP($J,""PRCPPOLMCOS"",Y))"
+3 WRITE !
DO ^DIC
+4 QUIT +Y
