PRCHCS2 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:51
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
COM ;S PRCHCOM=$S($D(^PRC(441.2,+$P(PRCH2,U,3),0)):$P(^(0),U,4),1:"") Q
S PRCHCOM=$P($G(^PRC(441.2,+$P(PRCH2,U,3),0)),U,4) Q
NOM S X=$S(PRCHCOM=1:$E($P(PRCHI0,U,2),1,20),PRCHCOM=8:$E($P(PRCHI0,U,2),1,13),1:$E($P(PRCHI0,U,2),1,16)) Q:PRCHCOM'=8
I PRCHDIET="" W $C(7),!!,"WARNING--DIETETICS COST PERIOD MISSING--WILL BE SET TO 'N'!!" S PRCHDIET="N"
S Y=X,PRCFLN=13 D RBF^PRCFU S PRCHZ=Y_PRCHDIET_$S($P(PRCH4,U,12):$P(PRCH4,U,12),1:" "),Y=$P(PRCH4,U,13),PRCFLN=5 D LBF^PRCFU S X=PRCHZ_Y K Y,PRCHZ Q
MAX S X="",PRCHCS("MAX")=$P(PRCHIV0,U,9) Q:'PRCHCS("MAX") S:$P(PRCH0,U,2)>PRCHCS("MAX") X=1 Q
MAND S X="",PRCHCS("MAND")="" Q:'$P(PRCHI0,U,8) Q:$D(^PRC(440,"AC","S",+$P(PRCHI0,U,8)))
S PRCHCS("MAND")=$S($D(^PRC(440,+$P(PRCHI0,U,8),2)):$P(^(2),U,2),1:PRCHCS("MAND"))
M2 I PRCHCS("MAND"),$P(PRCH4,U,10),PRCHCS("MAND")'=$P(PRCH4,U,10) W $C(7),!!,"NOTE: Possible Source deviation on line/item "_$P(PRCH0,U,1),!
Q
DOCID ;SET DOCUMENT IDENTIFIER TO COMMON NO.(PAT) OR REQUISITION NO. IF SOURCE 1 (DEPOT)
S X="" Q:'$D(^PRC(442,PRCHPO,18)) S X=^(18),X=$P(X,U,3)
Q
AMT ;SET X=AMOUNT ORDERED INCLUDING TERM & TRADE DISCOUNTS, AND SHIPPING/HANDLING CHARGES.
S X=$P(PRCH2,U,1)-$P(PRCH2,U,6)
S X=X-(X*PRCHS("T")) I PRCHEST S X=X+PRCHEST
S:X<0 X=0 S X=+$J(X,0,2)
Q
B500 ;POSTED ACQUISITIONS TRX# 630,500,504
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="D DOCID^PRCHCS2;344",PRCHTP(1,3)="7;306"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341"
S PRCHTP(2,5)="S X=$S($P(PRCH4,U,10)=1:"""",1:+PRCH2) D:X AMT^PRCHCS2;301",PRCHTP(2,6)="35;347",PRCHTP(2,7)="36;348",PRCHTP(2,8)="3;303"
S PRCHTP(2,9)="S Y=$E($P(PRCHI0,U,2),1,15),PRCFLN=15 D RBF^PRCFU S X=Y K Y;310",PRCHTP(2,10)="D MAX^PRCHCS2;349",PRCHTP(2,11)="D MAND^PRCHCS2;359" Q
Q
B100 ;DLA ACQUISITIONS TRX# 100
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="71;313",PRCHTP(1,3)="72;312",PRCHTP(1,4)="80;350",PRCHTP(1,5)="72.4;311",PRCHTP(1,6)=".1;306.2"
S PRCHTP(1,7)="73;351",PRCHTP(1,8)="S X=$P($P(^PRC(442,PRCHPO,0),U,1),""-"",2);367",PRCHTP(1,9)="102;344",PRCHTP(1,10)="74;352",PRCHTP(1,11)="75;353",PRCHTP(1,12)="76;354",PRCHTP(1,13)="77;355"
S PRCHTP(1,14)="78;356",PRCHTP(1,15)="7;358",PRCHTP(1,16)="79;357"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="30;366",PRCHTP(2,4)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",1)_$P(X,""-"",2)_$P(X,""-"",3)_$E($P(X,""-"",4),1,4);307"
S PRCHTP(2,5)="3;303"
Q
B501 ;UNPOSTED ACQUISITION--SOURCE 1 (DEPOT) TRX# 501,505,510,514,515
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="D DOCID^PRCHCS2;344",PRCHTP(1,3)="7;306",PRCHTP(1,4)="70;330"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341"
S PRCHTP(2,5)="35;347",PRCHTP(2,6)="36;348"
Q
B700 ;UNPOSTED ACQUISITION--SOURCE 3 (GSA) TRX# 700
S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="102;344",PRCHTP(1,3)="7;306",PRCHTP(1,4)="70;330",PRCHTP(1,5)="S X=""G"";340"
S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;302",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="39;341",PRCHTP(2,5)="D AMT^PRCHCS2;301"
S PRCHTP(2,6)="S X=$S($P(PRCH4,U,1)]"""":""*""_$P(PRCH4,U,1),1:$E($P(PRCHI0,U,2),1,9));310.6",PRCHTP(2,7)="3;303"
S PRCHTP(2,8)="8;364",PRCHTP(2,9)="35;347",PRCHTP(2,10)="36;348",PRCHTP(2,11)="D COM^PRCHCS2 S X=PRCHCOM;336"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS2 3647 printed Dec 13, 2024@02:06:18 Page 2
PRCHCS2 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:51
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
COM ;S PRCHCOM=$S($D(^PRC(441.2,+$P(PRCH2,U,3),0)):$P(^(0),U,4),1:"") Q
+1 SET PRCHCOM=$PIECE($GET(^PRC(441.2,+$PIECE(PRCH2,U,3),0)),U,4)
QUIT
NOM SET X=$SELECT(PRCHCOM=1:$EXTRACT($PIECE(PRCHI0,U,2),1,20),PRCHCOM=8:$EXTRACT($PIECE(PRCHI0,U,2),1,13),1:$EXTRACT($PIECE(PRCHI0,U,2),1,16))
if PRCHCOM'=8
QUIT
+1 IF PRCHDIET=""
WRITE $CHAR(7),!!,"WARNING--DIETETICS COST PERIOD MISSING--WILL BE SET TO 'N'!!"
SET PRCHDIET="N"
+2 SET Y=X
SET PRCFLN=13
DO RBF^PRCFU
SET PRCHZ=Y_PRCHDIET_$SELECT($PIECE(PRCH4,U,12):$PIECE(PRCH4,U,12),1:" ")
SET Y=$PIECE(PRCH4,U,13)
SET PRCFLN=5
DO LBF^PRCFU
SET X=PRCHZ_Y
KILL Y,PRCHZ
QUIT
MAX SET X=""
SET PRCHCS("MAX")=$PIECE(PRCHIV0,U,9)
if 'PRCHCS("MAX")
QUIT
if $PIECE(PRCH0,U,2)>PRCHCS("MAX")
SET X=1
QUIT
MAND SET X=""
SET PRCHCS("MAND")=""
if '$PIECE(PRCHI0,U,8)
QUIT
if $DATA(^PRC(440,"AC","S",+$PIECE(PRCHI0,U,8)))
QUIT
+1 SET PRCHCS("MAND")=$SELECT($DATA(^PRC(440,+$PIECE(PRCHI0,U,8),2)):$PIECE(^(2),U,2),1:PRCHCS("MAND"))
M2 IF PRCHCS("MAND")
IF $PIECE(PRCH4,U,10)
IF PRCHCS("MAND")'=$PIECE(PRCH4,U,10)
WRITE $CHAR(7),!!,"NOTE: Possible Source deviation on line/item "_$PIECE(PRCH0,U,1),!
+1 QUIT
DOCID ;SET DOCUMENT IDENTIFIER TO COMMON NO.(PAT) OR REQUISITION NO. IF SOURCE 1 (DEPOT)
+1 SET X=""
if '$DATA(^PRC(442,PRCHPO,18))
QUIT
SET X=^(18)
SET X=$PIECE(X,U,3)
+2 QUIT
AMT ;SET X=AMOUNT ORDERED INCLUDING TERM & TRADE DISCOUNTS, AND SHIPPING/HANDLING CHARGES.
+1 SET X=$PIECE(PRCH2,U,1)-$PIECE(PRCH2,U,6)
+2 SET X=X-(X*PRCHS("T"))
IF PRCHEST
SET X=X+PRCHEST
+3 if X<0
SET X=0
SET X=+$JUSTIFY(X,0,2)
+4 QUIT
B500 ;POSTED ACQUISITIONS TRX# 630,500,504
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="D DOCID^PRCHCS2;344"
SET PRCHTP(1,3)="7;306"
+2 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="2;302"
SET PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"
SET PRCHTP(2,4)="39;341"
+3 SET PRCHTP(2,5)="S X=$S($P(PRCH4,U,10)=1:"""",1:+PRCH2) D:X AMT^PRCHCS2;301"
SET PRCHTP(2,6)="35;347"
SET PRCHTP(2,7)="36;348"
SET PRCHTP(2,8)="3;303"
+4 SET PRCHTP(2,9)="S Y=$E($P(PRCHI0,U,2),1,15),PRCFLN=15 D RBF^PRCFU S X=Y K Y;310"
SET PRCHTP(2,10)="D MAX^PRCHCS2;349"
SET PRCHTP(2,11)="D MAND^PRCHCS2;359"
QUIT
+5 QUIT
B100 ;DLA ACQUISITIONS TRX# 100
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="71;313"
SET PRCHTP(1,3)="72;312"
SET PRCHTP(1,4)="80;350"
SET PRCHTP(1,5)="72.4;311"
SET PRCHTP(1,6)=".1;306.2"
+2 SET PRCHTP(1,7)="73;351"
SET PRCHTP(1,8)="S X=$P($P(^PRC(442,PRCHPO,0),U,1),""-"",2);367"
SET PRCHTP(1,9)="102;344"
SET PRCHTP(1,10)="74;352"
SET PRCHTP(1,11)="75;353"
SET PRCHTP(1,12)="76;354"
SET PRCHTP(1,13)="77;355"
+3 SET PRCHTP(1,14)="78;356"
SET PRCHTP(1,15)="7;358"
SET PRCHTP(1,16)="79;357"
+4 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="2;302"
SET PRCHTP(2,3)="30;366"
SET PRCHTP(2,4)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",1)_$P(X,""-"",2)_$P(X,""-"",3)_$E($P(X,""-"",4),1,4);307"
+5 SET PRCHTP(2,5)="3;303"
+6 QUIT
B501 ;UNPOSTED ACQUISITION--SOURCE 1 (DEPOT) TRX# 501,505,510,514,515
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="D DOCID^PRCHCS2;344"
SET PRCHTP(1,3)="7;306"
SET PRCHTP(1,4)="70;330"
+2 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="2;302"
SET PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"
SET PRCHTP(2,4)="39;341"
+3 SET PRCHTP(2,5)="35;347"
SET PRCHTP(2,6)="36;348"
+4 QUIT
B700 ;UNPOSTED ACQUISITION--SOURCE 3 (GSA) TRX# 700
+1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
SET PRCHTP(1,2)="102;344"
SET PRCHTP(1,3)="7;306"
SET PRCHTP(1,4)="70;330"
SET PRCHTP(1,5)="S X=""G"";340"
+2 SET PRCHTP(2,1)=".01;300"
SET PRCHTP(2,2)="2;302"
SET PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"
SET PRCHTP(2,4)="39;341"
SET PRCHTP(2,5)="D AMT^PRCHCS2;301"
+3 SET PRCHTP(2,6)="S X=$S($P(PRCH4,U,1)]"""":""*""_$P(PRCH4,U,1),1:$E($P(PRCHI0,U,2),1,9));310.6"
SET PRCHTP(2,7)="3;303"
+4 SET PRCHTP(2,8)="8;364"
SET PRCHTP(2,9)="35;347"
SET PRCHTP(2,10)="36;348"
SET PRCHTP(2,11)="D COM^PRCHCS2 S X=PRCHCOM;336"
+5 QUIT
