- 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 Mar 13, 2025@21:19:15 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
