PRCHDIS ;ID/RSD-X-REF OF DISCOUNT FIELD IN FILE 442 ;3/2/95 10:29 AM
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
DIS Q:X="Q" K ^TMP($J,"PRCHD"),PRCHD("LI") S PRCHD=0,PRCHD("AC")=0
F I=0:0 S PRCHD=$O(^PRC(442,D0,3,PRCHD)) Q:'PRCHD S K=$P(^(PRCHD,0),U,1) Q:K="Q" S:K[":" K=$P(K,":",1)_":1:"_$P(K,":",2) S PRCHD("DS")="F J="_K_" S ^TMP($J,""PRCHD"",J)=""""" X PRCHD("DS")
G 1:$L(X)>1&(X[",")&(X'[":"),2:X?.N1":".N,3:X?.N K X,PRCHD,^TMP($J,"PRCHD") Q
1 S:$E(X,$L(X))="," X=$E(X,1,$L(X)-1) F I=1:1 Q:'$D(X) S PRCHD=$P(X,",",I) Q:PRCHD="" D DIS1,DIS2:$D(X)
Q
2 S:$E(X,$L(X))=":" X=X_$P(^PRC(442,D0,2,0),U,4) ; <<<<<< REW to handle * "5:" by making it "5:last" patch 65 for NOIS BRX-1294-10197
X "F I="_$P(X,":",1)_":1:"_$P(X,":",2)_" Q:'$D(X) S PRCHD=I D DIS1,DIS2:$D(X)"
Q
3 S PRCHD=X D DIS1,DIS2:$D(X) Q
DIS1 I PRCHD>$P(^PRC(442,D0,2,0),U,4)!(PRCHD<1)!($D(^TMP($J,"PRCHD",PRCHD))) W " ??",$C(7),!," **ITEM ",PRCHD," IS NOT A VALID LINE ITEM OR IS IN ANOTHER DISCOUNT**" K X,PRCHD,^TMP($J,"PRCHD") Q
S PRCHD("AC")=PRCHD("AC")+1,^TMP($J,"PRCHD",PRCHD)="" Q
DIS2 G DIS21:'$D(PRCHD("LI")),ER:'$D(^TMP($J,"PRCHD","LI",PRCHD)) Q
DIS21 S PRCHD("CN")=0 F J=0:0 S PRCHD("CN")=$O(PRCH("AM",PRCHD("CN"))) G:PRCHD("CN")<0 ER1 D DIS221 Q:$D(PRCHD("LI"))
Q
DIS221 S PRCHD("CN3")=$P(PRCH("AM",PRCHD("CN")),U,3),PRCHD("CN3")=$E(PRCHD("CN3"),1,$L(PRCHD("CN3"))-1) X "F K="_PRCHD("CN3")_" I K=PRCHD D DIS22 Q" Q:$D(PRCHD("LI"))
Q
DIS22 X "F L="_PRCHD("CN3")_" S ^TMP($J,""PRCHD"",""LI"",L)=""""" S PRCHD("LI")="" Q
ER W $C(7),!," ** ITEM ",PRCHD," IS NOT ASSOCIATED WITH ",$S(PRCHD("CN")=".OM":"PURCHASE ORDER",1:"CONTRACT "_PRCHD("CN"))," **" K X,PRCHD,^TMP($J,"PRCHD") Q
ER1 W !,"** ERROR WITH LINE ITEM ",I,"**",$C(7) K X,PRCHD,^TMP($J,"PRCHD") Q
TERM S PRCHD=$O(^PRC(442,DA(1),2,"AC",X,0)) K:PRCHD<0 X I $D(^PRC(442,DA(1),2,PRCHD,2)) S PRCHD=$P(^(2),U,5),PRCHD("*")=$S(PRCHD]"":PRCHD,1:"") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDIS 1966 printed Dec 13, 2024@02:06:38 Page 2
PRCHDIS ;ID/RSD-X-REF OF DISCOUNT FIELD IN FILE 442 ;3/2/95 10:29 AM
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
DIS if X="Q"
QUIT
KILL ^TMP($JOB,"PRCHD"),PRCHD("LI")
SET PRCHD=0
SET PRCHD("AC")=0
+1 FOR I=0:0
SET PRCHD=$ORDER(^PRC(442,D0,3,PRCHD))
if 'PRCHD
QUIT
SET K=$PIECE(^(PRCHD,0),U,1)
if K="Q"
QUIT
if K["
SET K=$PIECE(K,":",1)_":1:"_$PIECE(K,":",2)
SET PRCHD("DS")="F J="_K_" S ^TMP($J,""PRCHD"",J)="""""
XECUTE PRCHD("DS")
+2 if $LENGTH(X)>1&(X[",")&(X'[":")
GOTO 1
if X?.N1":".N
GOTO 2
if X?.N
GOTO 3
KILL X,PRCHD,^TMP($JOB,"PRCHD")
QUIT
1 if $EXTRACT(X,$LENGTH(X))=","
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
FOR I=1:1
if '$DATA(X)
QUIT
SET PRCHD=$PIECE(X,",",I)
if PRCHD=""
QUIT
DO DIS1
if $DATA(X)
DO DIS2
+1 QUIT
2 ; <<<<<< REW to handle * "5:" by making it "5:last" patch 65 for NOIS BRX-1294-10197
if $EXTRACT(X,$LENGTH(X))="
SET X=X_$PIECE(^PRC(442,D0,2,0),U,4)
+1 XECUTE "F I="_$PIECE(X,":",1)_":1:"_$PIECE(X,":",2)_" Q:'$D(X) S PRCHD=I D DIS1,DIS2:$D(X)"
+2 QUIT
3 SET PRCHD=X
DO DIS1
if $DATA(X)
DO DIS2
QUIT
DIS1 IF PRCHD>$PIECE(^PRC(442,D0,2,0),U,4)!(PRCHD<1)!($DATA(^TMP($JOB,"PRCHD",PRCHD)))
WRITE " ??",$CHAR(7),!," **ITEM ",PRCHD," IS NOT A VALID LINE ITEM OR IS IN ANOTHER DISCOUNT**"
KILL X,PRCHD,^TMP($JOB,"PRCHD")
QUIT
+1 SET PRCHD("AC")=PRCHD("AC")+1
SET ^TMP($JOB,"PRCHD",PRCHD)=""
QUIT
DIS2 if '$DATA(PRCHD("LI"))
GOTO DIS21
if '$DATA(^TMP($JOB,"PRCHD","LI",PRCHD))
GOTO ER
QUIT
DIS21 SET PRCHD("CN")=0
FOR J=0:0
SET PRCHD("CN")=$ORDER(PRCH("AM",PRCHD("CN")))
if PRCHD("CN")<0
GOTO ER1
DO DIS221
if $DATA(PRCHD("LI"))
QUIT
+1 QUIT
DIS221 SET PRCHD("CN3")=$PIECE(PRCH("AM",PRCHD("CN")),U,3)
SET PRCHD("CN3")=$EXTRACT(PRCHD("CN3"),1,$LENGTH(PRCHD("CN3"))-1)
XECUTE "F K="_PRCHD("CN3")_" I K=PRCHD D DIS22 Q"
if $DATA(PRCHD("LI"))
QUIT
+1 QUIT
DIS22 XECUTE "F L="_PRCHD("CN3")_" S ^TMP($J,""PRCHD"",""LI"",L)="""""
SET PRCHD("LI")=""
QUIT
ER WRITE $CHAR(7),!," ** ITEM ",PRCHD," IS NOT ASSOCIATED WITH ",$SELECT(PRCHD("CN")=".OM":"PURCHASE ORDER",1:"CONTRACT "_PRCHD("CN"))," **"
KILL X,PRCHD,^TMP($JOB,"PRCHD")
QUIT
ER1 WRITE !,"** ERROR WITH LINE ITEM ",I,"**",$CHAR(7)
KILL X,PRCHD,^TMP($JOB,"PRCHD")
QUIT
TERM SET PRCHD=$ORDER(^PRC(442,DA(1),2,"AC",X,0))
if PRCHD<0
KILL X
IF $DATA(^PRC(442,DA(1),2,PRCHD,2))
SET PRCHD=$PIECE(^(2),U,5)
SET PRCHD("*")=$SELECT(PRCHD]"":PRCHD,1:"")
QUIT
