- PRCGARC1 ;WIRMFO@ALTOONA/CTB/BGJ - IFCAP ARCHIVE SUBROUTINES ;12/10/97 9:04 AM
- V ;;5.1;IFCAP;**147**;Oct 20, 2000;Build 3
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;;
- ;PRC*147 saving 410 link in 442 order record being archived to correctly handle 1358 doc print given error conditions from too many DA passed parameters in previous copy
- DOC(DA) ;completely archive 1 purchase order
- QUIT:$P($G(^PRC(442,DA,0)),"^",1)=""
- NEW VENDOR,X,XDA,IEN410 S X=$P($G(^PRC(442,DA,1)),"^") I X S VENDOR=$P($G(^PRC(440,+X,0)),"^")
- W "~~PRCG~~^",!,$P(^PRC(442,DA,0),"^",1)_"^"_$G(VENDOR)
- S ZNODE=$G(^PRC(442,DA,0)) Q:ZNODE=""
- S IEN410=$P($G(^PRC(442,DA,0)),"^",12) ;PRC*147 saving 410 linked to archived 442 ien for document printing
- S MOP=$P(ZNODE,"^",2)
- I MOP<1 S MOP="NULL" G DOIT
- S MOP=$P($G(^PRCD(442.5,MOP,0)),"^",2)
- I MOP="" S MOP="NULL"
- S XDA=DA ;PRC*147 saving archive 442 ien
- DOIT U MTIO S IO=MTIO D @MOP S IO=DEVIO
- QUIT
- CI ;certified invoice
- PIA ;payment in advance
- DD ;guaranteed delivery
- ST ;invoice/receiving report
- IF ;imprest fund
- RQ ;requisition
- PC ;purchase card
- AB ;autobank
- AR ;accounts receivable
- NULL D PO(DA)
- D ALLRR(DA)
- D ALL410
- QUIT
- 1358 ;misc obligation
- I +IEN410,$D(^PRCS(410,+IEN410,0)) D ALL410
- Q
- IS ;issue
- TA ;travel authority
- OTA ;open travel authority
- QUIT
- PO(DA) ;archive one purchase order
- S D0=DA D ^PRCHFPNT
- QUIT
- ALLRR(DA) ;archive all receiving reports for a PO (DA)
- NEW RRNUM
- S RRNUM=""
- F S RRNUM=$O(^PRC(442,DA,11,RRNUM)) Q:'RRNUM I RRNUM>0 S D0=DA,PRCHFPT=RRNUM D ^PRCHFPNT
- QUIT
- ALL410 ;archive all 410 documents related to PO (DA)
- NEW N,DA410,X,PRIMARY
- ;primary
- S PRIMARY=+IEN410 I $D(^PRCS(410,+IEN410,0)) D 410(IEN410)
- ;any other 2237s on PO
- S N=""
- F S N=$O(^PRC(442,DA,13,N)) Q:'N S DA410=$P($G(^(N,0)),"^") I DA410,$D(^PRCS(410,DA410,0)),DA410'=PRIMARY D 410(DA410)
- QUIT
- 410(DA) ;archive 1 410 record
- Q:+DA=0
- N TRNODE,X2237 S X2237=$P($G(^PRCS(410,DA,0)),"^",4)
- I X2237=1 S TRNODE(0)="" D NODE^PRCS58OB(DA,.TRNODE),^PRCE58P2
- D:X2237=5 DQ^PRCPRIB0 D:(X2237'=1)&(X2237'=5) ^PRCSP12
- QUIT
- ERR ;go here when tape error
- QUIT X ^%ZOSF("MTERR") I 'Y S %ZTERLGR=OLDET D ^%ZTER
- U MTIO W @%MT("BS") D G V
- . U MTIO R X:10 Q:'$T
- . I X["DAV/VHA IFCAP ARCHIVE" D
- . . W @%MT("BS"),@%MT("WEL"),%MT("REW")
- . . F D G:X["^" END X ^%ZOSF("MTONLINE") Q:Y=1
- . . . U IO(0) R !!,"Please load new tape and press <CR> to continue",X:1200
- . . . QUIT
- . . U MTIO W @%MT("BS"),@%MT("BS")
- . . QUIT
- ;
- END ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCGARC1 2563 printed Feb 18, 2025@23:31:07 Page 2
- PRCGARC1 ;WIRMFO@ALTOONA/CTB/BGJ - IFCAP ARCHIVE SUBROUTINES ;12/10/97 9:04 AM
- V ;;5.1;IFCAP;**147**;Oct 20, 2000;Build 3
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;;
- +3 ;PRC*147 saving 410 link in 442 order record being archived to correctly handle 1358 doc print given error conditions from too many DA passed parameters in previous copy
- DOC(DA) ;completely archive 1 purchase order
- +1 if $PIECE($GET(^PRC(442,DA,0)),"^",1)=""
- QUIT
- +2 NEW VENDOR,X,XDA,IEN410
- SET X=$PIECE($GET(^PRC(442,DA,1)),"^")
- IF X
- SET VENDOR=$PIECE($GET(^PRC(440,+X,0)),"^")
- +3 WRITE "~~PRCG~~^",!,$PIECE(^PRC(442,DA,0),"^",1)_"^"_$GET(VENDOR)
- +4 SET ZNODE=$GET(^PRC(442,DA,0))
- if ZNODE=""
- QUIT
- +5 ;PRC*147 saving 410 linked to archived 442 ien for document printing
- SET IEN410=$PIECE($GET(^PRC(442,DA,0)),"^",12)
- +6 SET MOP=$PIECE(ZNODE,"^",2)
- +7 IF MOP<1
- SET MOP="NULL"
- GOTO DOIT
- +8 SET MOP=$PIECE($GET(^PRCD(442.5,MOP,0)),"^",2)
- +9 IF MOP=""
- SET MOP="NULL"
- +10 ;PRC*147 saving archive 442 ien
- SET XDA=DA
- DOIT USE MTIO
- SET IO=MTIO
- DO @MOP
- SET IO=DEVIO
- +1 QUIT
- CI ;certified invoice
- PIA ;payment in advance
- DD ;guaranteed delivery
- ST ;invoice/receiving report
- IF ;imprest fund
- RQ ;requisition
- PC ;purchase card
- AB ;autobank
- AR ;accounts receivable
- NULL DO PO(DA)
- +1 DO ALLRR(DA)
- +2 DO ALL410
- +3 QUIT
- 1358 ;misc obligation
- +1 IF +IEN410
- IF $DATA(^PRCS(410,+IEN410,0))
- DO ALL410
- +2 QUIT
- IS ;issue
- TA ;travel authority
- OTA ;open travel authority
- +1 QUIT
- PO(DA) ;archive one purchase order
- +1 SET D0=DA
- DO ^PRCHFPNT
- +2 QUIT
- ALLRR(DA) ;archive all receiving reports for a PO (DA)
- +1 NEW RRNUM
- +2 SET RRNUM=""
- +3 FOR
- SET RRNUM=$ORDER(^PRC(442,DA,11,RRNUM))
- if 'RRNUM
- QUIT
- IF RRNUM>0
- SET D0=DA
- SET PRCHFPT=RRNUM
- DO ^PRCHFPNT
- +4 QUIT
- ALL410 ;archive all 410 documents related to PO (DA)
- +1 NEW N,DA410,X,PRIMARY
- +2 ;primary
- +3 SET PRIMARY=+IEN410
- IF $DATA(^PRCS(410,+IEN410,0))
- DO 410(IEN410)
- +4 ;any other 2237s on PO
- +5 SET N=""
- +6 FOR
- SET N=$ORDER(^PRC(442,DA,13,N))
- if 'N
- QUIT
- SET DA410=$PIECE($GET(^(N,0)),"^")
- IF DA410
- IF $DATA(^PRCS(410,DA410,0))
- IF DA410'=PRIMARY
- DO 410(DA410)
- +7 QUIT
- 410(DA) ;archive 1 410 record
- +1 if +DA=0
- QUIT
- +2 NEW TRNODE,X2237
- SET X2237=$PIECE($GET(^PRCS(410,DA,0)),"^",4)
- +3 IF X2237=1
- SET TRNODE(0)=""
- DO NODE^PRCS58OB(DA,.TRNODE)
- DO ^PRCE58P2
- +4 if X2237=5
- DO DQ^PRCPRIB0
- if (X2237'=1)&(X2237'=5)
- DO ^PRCSP12
- +5 QUIT
- ERR ;go here when tape error
- +1 QUIT
- XECUTE ^%ZOSF("MTERR")
- IF 'Y
- SET %ZTERLGR=OLDET
- DO ^%ZTER
- +2 USE MTIO
- WRITE @%MT("BS")
- Begin DoDot:1
- +3 USE MTIO
- READ X:10
- if '$TEST
- QUIT
- +4 IF X["DAV/VHA IFCAP ARCHIVE"
- Begin DoDot:2
- +5 WRITE @%MT("BS"),@%MT("WEL"),%MT("REW")
- +6 FOR
- Begin DoDot:3
- +7 USE IO(0)
- READ !!,"Please load new tape and press <CR> to continue",X:1200
- +8 QUIT
- End DoDot:3
- if X["^"
- GOTO END
- XECUTE ^%ZOSF("MTONLINE")
- if Y=1
- QUIT
- +9 USE MTIO
- WRITE @%MT("BS"),@%MT("BS")
- +10 QUIT
- End DoDot:2
- End DoDot:1
- GOTO V
- +11 ;
- END ;