PRCFFU7 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES, CON'T ;7/24/00 23:10
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
LIST(POIEN,AMIEN) ;
; POIEN - Internal Entry Number of Purchase Order
; AMIEN - Internal Entry Number of Amendment
VAR ; Initialize some variables
K PRCFCHG("BOC")
S (AMT,TOTAMT)=0
S PRCFA("MOMREQ")=0,PRCFA("MOMNOTREQ")=0
F LOOP1="AUTHE","BOC","DEL","DELSCH","FCP","FOB","PO","PPT","VEND" S PRCFA(LOOP1)=""
S LOOP=0 F S LOOP=$O(^PRC(442,POIEN,6,AMIEN,3,LOOP)) Q:LOOP'>0 D
.S STRING=^PRC(442,POIEN,6,AMIEN,3,LOOP,0)
.S CHG=+$P(STRING,U,2)
.Q:CHG=99 Q:PRCFA("FCP") Q:PRCFA("VEND")
.S OLD(LOOP)=STRING
.S OLDVAL=^PRC(442,POIEN,6,AMIEN,3,LOOP,1,1,0)
.S OLD(LOOP,1)=OLDVAL
.S TAG="TAG"_CHG_"^PRCFFU9" D @TAG
.Q
N SUBINFO,AMDSTAT,AUTH S SUBINFO="442.07^3;9^"_AMIEN
D GENDIQ(442,POIEN,50,"IEN",SUBINFO)
S AMDSTAT=+$G(PRCTMP(442.07,AMIEN,9,"I"))
S AUTH=$G(PRCTMP(442.07,AMIEN,3,"E"))
I (AMDSTAT=45)&(AUTH="E") D TAGE^PRCFFU9
I $D(PRCFCHG("BOC"))\10 D TOTAL S:TOTAMT<0 TOTAMT=-TOTAMT
I '$D(PRCFCHG("BOC")),'$D(PRCFA("CANCEL")) S PRCFA("MOMNOTREQ")=1,PRCFA("MOMREQ")=0,PRCFA("ZERO")="NO CHARGE AMENDMENT"
KILL AMT,CHG,LOOP,LOOP1,LOOP2,LOOP3,LOOP4,OLD,OLDVAL,STRING,TAG
QUIT
;
GENDIQ(DIC,DA,DR,PARAM,PARAM1) ; Generic call to DIQ1 utility
N DIQ,SUBFILE,SUBFLD,SUBREC S DIQ="PRCTMP(",DIQ(0)=PARAM
I PARAM1]"" D
.S SUBFILE=$P(PARAM1,U),SUBFLD=$P(PARAM1,U,2),SUBREC=$P(PARAM1,U,3)
.S DR(SUBFILE)=SUBFLD,DA(SUBFILE)=SUBREC
D EN^DIQ1
Q
TOTAL ; Calculate total for changes
S LOOP3="" F S LOOP3=$O(PRCFCHG("BOC",LOOP3)) Q:LOOP3="" D
.S LOOP4="" F S LOOP4=$O(PRCFCHG("BOC",LOOP3,LOOP4)) Q:LOOP4="" D
..S AMT=$P(PRCFCHG("BOC",LOOP3,LOOP4),U,2)
..S TOTAMT=TOTAMT+AMT
..I AMT<0 S AMT=-AMT,$P(PRCFCHG("BOC",LOOP3,LOOP4),U,2)=AMT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU7 1870 printed Dec 13, 2024@02:03:52 Page 2
PRCFFU7 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES, CON'T ;7/24/00 23:10
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
LIST(POIEN,AMIEN) ;
+1 ; POIEN - Internal Entry Number of Purchase Order
+2 ; AMIEN - Internal Entry Number of Amendment
VAR ; Initialize some variables
+1 KILL PRCFCHG("BOC")
+2 SET (AMT,TOTAMT)=0
+3 SET PRCFA("MOMREQ")=0
SET PRCFA("MOMNOTREQ")=0
+4 FOR LOOP1="AUTHE","BOC","DEL","DELSCH","FCP","FOB","PO","PPT","VEND"
SET PRCFA(LOOP1)=""
+5 SET LOOP=0
FOR
SET LOOP=$ORDER(^PRC(442,POIEN,6,AMIEN,3,LOOP))
if LOOP'>0
QUIT
Begin DoDot:1
+6 SET STRING=^PRC(442,POIEN,6,AMIEN,3,LOOP,0)
+7 SET CHG=+$PIECE(STRING,U,2)
+8 if CHG=99
QUIT
if PRCFA("FCP")
QUIT
if PRCFA("VEND")
QUIT
+9 SET OLD(LOOP)=STRING
+10 SET OLDVAL=^PRC(442,POIEN,6,AMIEN,3,LOOP,1,1,0)
+11 SET OLD(LOOP,1)=OLDVAL
+12 SET TAG="TAG"_CHG_"^PRCFFU9"
DO @TAG
+13 QUIT
End DoDot:1
+14 NEW SUBINFO,AMDSTAT,AUTH
SET SUBINFO="442.07^3;9^"_AMIEN
+15 DO GENDIQ(442,POIEN,50,"IEN",SUBINFO)
+16 SET AMDSTAT=+$GET(PRCTMP(442.07,AMIEN,9,"I"))
+17 SET AUTH=$GET(PRCTMP(442.07,AMIEN,3,"E"))
+18 IF (AMDSTAT=45)&(AUTH="E")
DO TAGE^PRCFFU9
+19 IF $DATA(PRCFCHG("BOC"))\10
DO TOTAL
if TOTAMT<0
SET TOTAMT=-TOTAMT
+20 IF '$DATA(PRCFCHG("BOC"))
IF '$DATA(PRCFA("CANCEL"))
SET PRCFA("MOMNOTREQ")=1
SET PRCFA("MOMREQ")=0
SET PRCFA("ZERO")="NO CHARGE AMENDMENT"
+21 KILL AMT,CHG,LOOP,LOOP1,LOOP2,LOOP3,LOOP4,OLD,OLDVAL,STRING,TAG
+22 QUIT
+23 ;
GENDIQ(DIC,DA,DR,PARAM,PARAM1) ; Generic call to DIQ1 utility
+1 NEW DIQ,SUBFILE,SUBFLD,SUBREC
SET DIQ="PRCTMP("
SET DIQ(0)=PARAM
+2 IF PARAM1]""
Begin DoDot:1
+3 SET SUBFILE=$PIECE(PARAM1,U)
SET SUBFLD=$PIECE(PARAM1,U,2)
SET SUBREC=$PIECE(PARAM1,U,3)
+4 SET DR(SUBFILE)=SUBFLD
SET DA(SUBFILE)=SUBREC
End DoDot:1
+5 DO EN^DIQ1
+6 QUIT
TOTAL ; Calculate total for changes
+1 SET LOOP3=""
FOR
SET LOOP3=$ORDER(PRCFCHG("BOC",LOOP3))
if LOOP3=""
QUIT
Begin DoDot:1
+2 SET LOOP4=""
FOR
SET LOOP4=$ORDER(PRCFCHG("BOC",LOOP3,LOOP4))
if LOOP4=""
QUIT
Begin DoDot:2
+3 SET AMT=$PIECE(PRCFCHG("BOC",LOOP3,LOOP4),U,2)
+4 SET TOTAMT=TOTAMT+AMT
+5 IF AMT<0
SET AMT=-AMT
SET $PIECE(PRCFCHG("BOC",LOOP3,LOOP4),U,2)=AMT
End DoDot:2
End DoDot:1
+6 QUIT
