- PRCFFUA4 ;WISC/SJG-ROUTINE TO PROCESS OBLIGATIONS ;4/27/94 11:30
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- QUIT
- ;
- ARRAY ; Determine items that changed on the amendment
- N LOOP,LINEITEM,FANDF,TYPE,N63
- K ITRAY S LOOP=0
- D GETBOC
- ARR1 I FILE=442 F S LOOP=$O(^PRC(442,+PO,6,PRCFAA,3,LOOP)) Q:LOOP=""!(LOOP'>0) D
- .S N63=^PRC(442,+PO,6,PRCFAA,3,LOOP,0),TYPE=$P(N63,U,2),FANDF=$P(N63,U,3),LINEITEM=$P(^PRC(442,+PO,6,PRCFAA,3,LOOP,0),U,4)
- .I $P(FANDF,":",2)=40,("^21^23^"[("^"_TYPE_"^")) S ITRAY(LINEITEM)="" Q
- .I TYPE=22 S ITRAY("CANCEL",LINEITEM)="" Q
- .I ("^29^35^"[("^"_TYPE_"^")) S ITRAY("ESH")="" Q
- .Q
- I FILE=442&('$D(ITRAY)) S ITRAY("NOITEMS")=""
- ARR2 I FILE=443.6 F S LOOP=$O(^PRC(443.6,+PO,6,PRCFAA,3,LOOP)) Q:LOOP=""!(LOOP'>0) D
- .S N63=^PRC(443.6,+PO,6,PRCFAA,3,LOOP,0),TYPE=$P(N63,U,2),FANDF=$P(N63,U,3),LINEITEM=$P(^PRC(443.6,+PO,6,PRCFAA,3,LOOP,0),U,4)
- .I $P(FANDF,":",2)=40,("^21^23^"[("^"_TYPE_"^")) S ITRAY(LINEITEM)="" Q
- .I TYPE=22 S ITRAY("CANCEL",LINEITEM)="" Q
- .I ("^29^35^"[("^"_TYPE_"^")) S ITRAY("ESH")="" Q
- .Q
- D CHKBOC
- I FILE=443.6&('$D(ITRAY)) S ITRAY("NOITEMS")=""
- Q
- GETBOC ; Get ESHBOCs from original and amendment
- N FILEL
- F FILEL=442,443.6 D GENDIQ^PRCFFU7(FILEL,+PO,"13;13.05","IEN","")
- S OESHBOC=$G(PRCTMP(442,+PO,13.05,"I")),AESHBOC=$G(PRCTMP(443.6,+PO,13.05,"I"))
- Q
- CHKBOC ; Check BOCs
- I $G(PRCFA("RETRAN"))=0 D Q
- .I OESHBOC]""&(AESHBOC]"") I OESHBOC'=AESHBOC D MSG11^PRCFFUA3 S FATAL=1 Q
- .I OESHBOC]""&(AESHBOC]"") I OESHBOC=AESHBOC K ITRAY("ESH") S FATAL=2
- .I OESHBOC=""&(AESHBOC]"") I FILE=443.6 S ITRAY("ESH")="",FATAL=2
- I $G(PRCFA("RETRAN"))=1 D
- .I $D(^PRC(443.6,+PO)) S FATAL=1 W ! D EN^DDIOL("An amendment exists for this Purchase Order - cannot rebuild and transmit!") W ! H 3 Q
- .I OESHBOC]""&(AESHBOC="") I $D(ITRAY("ESH")) S FATAL=2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFUA4 1901 printed Mar 13, 2025@21:08:47 Page 2
- PRCFFUA4 ;WISC/SJG-ROUTINE TO PROCESS OBLIGATIONS ;4/27/94 11:30
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- +3 QUIT
- +4 ;
- ARRAY ; Determine items that changed on the amendment
- +1 NEW LOOP,LINEITEM,FANDF,TYPE,N63
- +2 KILL ITRAY
- SET LOOP=0
- +3 DO GETBOC
- ARR1 IF FILE=442
- FOR
- SET LOOP=$ORDER(^PRC(442,+PO,6,PRCFAA,3,LOOP))
- if LOOP=""!(LOOP'>0)
- QUIT
- Begin DoDot:1
- +1 SET N63=^PRC(442,+PO,6,PRCFAA,3,LOOP,0)
- SET TYPE=$PIECE(N63,U,2)
- SET FANDF=$PIECE(N63,U,3)
- SET LINEITEM=$PIECE(^PRC(442,+PO,6,PRCFAA,3,LOOP,0),U,4)
- +2 IF $PIECE(FANDF,":",2)=40
- IF ("^21^23^"[("^"_TYPE_"^"))
- SET ITRAY(LINEITEM)=""
- QUIT
- +3 IF TYPE=22
- SET ITRAY("CANCEL",LINEITEM)=""
- QUIT
- +4 IF ("^29^35^"[("^"_TYPE_"^"))
- SET ITRAY("ESH")=""
- QUIT
- +5 QUIT
- End DoDot:1
- +6 IF FILE=442&('$DATA(ITRAY))
- SET ITRAY("NOITEMS")=""
- ARR2 IF FILE=443.6
- FOR
- SET LOOP=$ORDER(^PRC(443.6,+PO,6,PRCFAA,3,LOOP))
- if LOOP=""!(LOOP'>0)
- QUIT
- Begin DoDot:1
- +1 SET N63=^PRC(443.6,+PO,6,PRCFAA,3,LOOP,0)
- SET TYPE=$PIECE(N63,U,2)
- SET FANDF=$PIECE(N63,U,3)
- SET LINEITEM=$PIECE(^PRC(443.6,+PO,6,PRCFAA,3,LOOP,0),U,4)
- +2 IF $PIECE(FANDF,":",2)=40
- IF ("^21^23^"[("^"_TYPE_"^"))
- SET ITRAY(LINEITEM)=""
- QUIT
- +3 IF TYPE=22
- SET ITRAY("CANCEL",LINEITEM)=""
- QUIT
- +4 IF ("^29^35^"[("^"_TYPE_"^"))
- SET ITRAY("ESH")=""
- QUIT
- +5 QUIT
- End DoDot:1
- +6 DO CHKBOC
- +7 IF FILE=443.6&('$DATA(ITRAY))
- SET ITRAY("NOITEMS")=""
- +8 QUIT
- GETBOC ; Get ESHBOCs from original and amendment
- +1 NEW FILEL
- +2 FOR FILEL=442,443.6
- DO GENDIQ^PRCFFU7(FILEL,+PO,"13;13.05","IEN","")
- +3 SET OESHBOC=$GET(PRCTMP(442,+PO,13.05,"I"))
- SET AESHBOC=$GET(PRCTMP(443.6,+PO,13.05,"I"))
- +4 QUIT
- CHKBOC ; Check BOCs
- +1 IF $GET(PRCFA("RETRAN"))=0
- Begin DoDot:1
- +2 IF OESHBOC]""&(AESHBOC]"")
- IF OESHBOC'=AESHBOC
- DO MSG11^PRCFFUA3
- SET FATAL=1
- QUIT
- +3 IF OESHBOC]""&(AESHBOC]"")
- IF OESHBOC=AESHBOC
- KILL ITRAY("ESH")
- SET FATAL=2
- +4 IF OESHBOC=""&(AESHBOC]"")
- IF FILE=443.6
- SET ITRAY("ESH")=""
- SET FATAL=2
- End DoDot:1
- QUIT
- +5 IF $GET(PRCFA("RETRAN"))=1
- Begin DoDot:1
- +6 IF $DATA(^PRC(443.6,+PO))
- SET FATAL=1
- WRITE !
- DO EN^DDIOL("An amendment exists for this Purchase Order - cannot rebuild and transmit!")
- WRITE !
- HANG 3
- QUIT
- +7 IF OESHBOC]""&(AESHBOC="")
- IF $DATA(ITRAY("ESH"))
- SET FATAL=2
- End DoDot:1
- +8 QUIT
