- PRCHCS7 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- STK S PRCHSRC=$P(PRCH4,U,10) I PRCHSRC'=1,PRCHCOM=1 D DRG K Y Q
- S X=$P(PRCH0,U,13),X=$P(X,"-",2)_$P(X,"-",3)_$P(X,"-",4) Q
- DRG ;DRUG FOR CODE SHEET
- S X=$P(PRCH0,U,15),X=$P(X,"-",1)_$P(X,"-",2)_$P(X,"-",3) G:PRCHN("SFC")=2 SDRG
- I X="" S Y="",PRCFLN=12 D RZF^PRCFU S X=Y
- S:$L(X)<11 X="0"_X S Y=$S($P(PRCH4,U,11)]"":$P(PRCH4,U,11),1:"D")_X,PRCFLN=13 D:$L(X)<13 RBF^PRCFU S X=Y Q
- SDRG S Y="DRUG D"_X,PRCFLN=21 D RZF^PRCFU S X=Y Q
- NOM2 I PRCHCOM'=1!(PRCHN("SC")=1)!(PRCHN("SC")="A") S X=$E($P(PRCHI0,U,2),1,21) Q
- D DRG Q
- RAMT ;SET X=AMOUNT RECEIVED INCLUDING TERM & TRADE DISCOUNTS, AND (IF FIRST PARTIAL), SHIPPING/HANDLING CHARGES.
- ;SET PRCHQTY=QTY.RECEIVED
- S X="",PRCHQTY="",Y=$O(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0)) Q:'$D(^PRC(442,PRCHPO,2,PRCHLI,3,+Y,0)) S X=$P(^(0),U,3)-$P(^(0),U,5),PRCHQTY=+$P(^(0),U,2)
- S X=X-(X*PRCHS("T")) I PRCHEST S X=X+PRCHEST
- S:X<0 X=0 S X=+$J(X,0,2)
- K Y Q
- B710 ;UNPOSTED RECEIPTS (EXCEPT FOR DEPOT)
- S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="101;346",PRCHTP(1,3)="102;344",PRCHTP(1,4)="S X=PRCHN(""FMO"");305",PRCHTP(1,5)="70;330"
- S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="D COM^PRCHCS2,STK^PRCHCS7;307",PRCHTP(2,3)="39;341",PRCHTP(2,4)="D NOM^PRCHCS2;310.5",PRCHTP(2,5)="3;303"
- S PRCHTP(2,6)="D RAMT^PRCHCS7;301",PRCHTP(2,7)="S X=PRCHQTY;302",PRCHTP(2,8)="S X=PRCHCOM;336",PRCHTP(2,9)="D CMDTY^PRCHCS7;306.1"
- S PRCHTP(2,10)="S X="""" I PRCHEMG=""Y"",$P(PRCH4,U,10)=2,""1,2""[PRCHCOM S X=""*"";383"
- Q
- B632 ;POSTED RECEIPTS (EXCEPT FOR DEPOT)
- W !!!,$C(7),$C(7),"WARNING!!!",!,"If the Unit of Receipt into the Warehouse is not the same as the Unit of Issue",!,"from the Warehouse on any items, you will need to edit the 'UNIT OF ISSUE' and"
- W !,"'QUANTITY' fields on the code sheets for those items.",!
- S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="S X=1 I $D(^PRC(442,PRCHPO,17)),$P(^(17),U,14)]"""" S X=$P(^(17),U,14);340"
- S PRCHTP(1,3)="S X="""" I ""01""[PRCHN(""SC""),$D(^PRC(442,PRCHPO,18)) S X=$P(^(18),U,3);344",PRCHTP(1,4)="S X=PRCHCMI;343",PRCHTP(1,5)="D DOCID^PRCHCS2;377"
- S PRCHTP(1,6)="107;345",PRCHTP(1,7)="101;346",PRCHTP(1,8)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4) S:$L(X)=2 X=$E(X,2,2);304",PRCHTP(1,9)="S X=PRCHRD;306.1"
- S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,3)="39;341",PRCHTP(2,4)="D COM^PRCHCS2,NOM2^PRCHCS7;309",PRCHTP(2,5)="3;303"
- S PRCHTP(2,6)="D RAMT^PRCHCS7;301",PRCHTP(2,7)="39.5;342",PRCHTP(2,8)="S X=PRCHQTY;302"
- Q
- B551 ;POSTED DEPOT RECEIPT CODE SHEET (RELEASE)
- S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="107;345",PRCHTP(1,3)=".09;368",PRCHTP(1,4)="D DOCID^PRCHCS2;369"
- S PRCHTP(1,5)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4);304",PRCHTP(1,6)="S X=""R"";370",PRCHTP(1,7)="102;344"
- Q
- B552 ;UNPOSTED DEPOT RECEIPT CODE SHEETS (RELEASE)
- S PRCHTP(1,1)="S X=PRCHPO;5.1",PRCHTP(1,2)="107;345",PRCHTP(1,3)=".09;368",PRCHTP(1,4)="D DOCID^PRCHCS2;369",PRCHTP(1,5)="70;330"
- S PRCHTP(1,6)="S X=""R"";370",PRCHTP(1,7)="102;344",PRCHTP(1,8)="S X=PRCHN(""FMO"");305",PRCHTP(1,9)="S X=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:"""");333"
- Q
- CMDTY S X="" I PRCHCOM=8,$D(^PRC(442,PRCHPO,17)),$E(^(17),1,2)=11 S X=$P(PRCHRD,".",1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHCS7 3417 printed Mar 13, 2025@21:11:11 Page 2
- PRCHCS7 ;WISC/RHD-BUILD LOG CODE SHEET DATA ;12/1/93 09:53
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- STK SET PRCHSRC=$PIECE(PRCH4,U,10)
- IF PRCHSRC'=1
- IF PRCHCOM=1
- DO DRG
- KILL Y
- QUIT
- +1 SET X=$PIECE(PRCH0,U,13)
- SET X=$PIECE(X,"-",2)_$PIECE(X,"-",3)_$PIECE(X,"-",4)
- QUIT
- DRG ;DRUG FOR CODE SHEET
- +1 SET X=$PIECE(PRCH0,U,15)
- SET X=$PIECE(X,"-",1)_$PIECE(X,"-",2)_$PIECE(X,"-",3)
- if PRCHN("SFC")=2
- GOTO SDRG
- +2 IF X=""
- SET Y=""
- SET PRCFLN=12
- DO RZF^PRCFU
- SET X=Y
- +3 if $LENGTH(X)<11
- SET X="0"_X
- SET Y=$SELECT($PIECE(PRCH4,U,11)]"":$PIECE(PRCH4,U,11),1:"D")_X
- SET PRCFLN=13
- if $LENGTH(X)<13
- DO RBF^PRCFU
- SET X=Y
- QUIT
- SDRG SET Y="DRUG D"_X
- SET PRCFLN=21
- DO RZF^PRCFU
- SET X=Y
- QUIT
- NOM2 IF PRCHCOM'=1!(PRCHN("SC")=1)!(PRCHN("SC")="A")
- SET X=$EXTRACT($PIECE(PRCHI0,U,2),1,21)
- QUIT
- +1 DO DRG
- QUIT
- RAMT ;SET X=AMOUNT RECEIVED INCLUDING TERM & TRADE DISCOUNTS, AND (IF FIRST PARTIAL), SHIPPING/HANDLING CHARGES.
- +1 ;SET PRCHQTY=QTY.RECEIVED
- +2 SET X=""
- SET PRCHQTY=""
- SET Y=$ORDER(^PRC(442,PRCHPO,2,"AB",PRCHRD,PRCHLI,0))
- if '$DATA(^PRC(442,PRCHPO,2,PRCHLI,3,+Y,0))
- QUIT
- SET X=$PIECE(^(0),U,3)-$PIECE(^(0),U,5)
- SET PRCHQTY=+$PIECE(^(0),U,2)
- +3 SET X=X-(X*PRCHS("T"))
- IF PRCHEST
- SET X=X+PRCHEST
- +4 if X<0
- SET X=0
- SET X=+$JUSTIFY(X,0,2)
- +5 KILL Y
- QUIT
- B710 ;UNPOSTED RECEIPTS (EXCEPT FOR DEPOT)
- +1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
- SET PRCHTP(1,2)="101;346"
- SET PRCHTP(1,3)="102;344"
- SET PRCHTP(1,4)="S X=PRCHN(""FMO"");305"
- SET PRCHTP(1,5)="70;330"
- +2 SET PRCHTP(2,1)=".01;300"
- SET PRCHTP(2,2)="D COM^PRCHCS2,STK^PRCHCS7;307"
- SET PRCHTP(2,3)="39;341"
- SET PRCHTP(2,4)="D NOM^PRCHCS2;310.5"
- SET PRCHTP(2,5)="3;303"
- +3 SET PRCHTP(2,6)="D RAMT^PRCHCS7;301"
- SET PRCHTP(2,7)="S X=PRCHQTY;302"
- SET PRCHTP(2,8)="S X=PRCHCOM;336"
- SET PRCHTP(2,9)="D CMDTY^PRCHCS7;306.1"
- +4 SET PRCHTP(2,10)="S X="""" I PRCHEMG=""Y"",$P(PRCH4,U,10)=2,""1,2""[PRCHCOM S X=""*"";383"
- +5 QUIT
- B632 ;POSTED RECEIPTS (EXCEPT FOR DEPOT)
- +1 WRITE !!!,$CHAR(7),$CHAR(7),"WARNING!!!",!,"If the Unit of Receipt into the Warehouse is not the same as the Unit of Issue",!,"from the Warehouse on any items, you will need to edit the 'UNIT OF ISSUE' and"
- +2 WRITE !,"'QUANTITY' fields on the code sheets for those items.",!
- +3 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
- SET PRCHTP(1,2)="S X=1 I $D(^PRC(442,PRCHPO,17)),$P(^(17),U,14)]"""" S X=$P(^(17),U,14);340"
- +4 SET PRCHTP(1,3)="S X="""" I ""01""[PRCHN(""SC""),$D(^PRC(442,PRCHPO,18)) S X=$P(^(18),U,3);344"
- SET PRCHTP(1,4)="S X=PRCHCMI;343"
- SET PRCHTP(1,5)="D DOCID^PRCHCS2;377"
- +5 SET PRCHTP(1,6)="107;345"
- SET PRCHTP(1,7)="101;346"
- SET PRCHTP(1,8)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4) S:$L(X)=2 X=$E(X,2,2);304"
- SET PRCHTP(1,9)="S X=PRCHRD;306.1"
- +6 SET PRCHTP(2,1)=".01;300"
- SET PRCHTP(2,2)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"
- SET PRCHTP(2,3)="39;341"
- SET PRCHTP(2,4)="D COM^PRCHCS2,NOM2^PRCHCS7;309"
- SET PRCHTP(2,5)="3;303"
- +7 SET PRCHTP(2,6)="D RAMT^PRCHCS7;301"
- SET PRCHTP(2,7)="39.5;342"
- SET PRCHTP(2,8)="S X=PRCHQTY;302"
- +8 QUIT
- B551 ;POSTED DEPOT RECEIPT CODE SHEET (RELEASE)
- +1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
- SET PRCHTP(1,2)="107;345"
- SET PRCHTP(1,3)=".09;368"
- SET PRCHTP(1,4)="D DOCID^PRCHCS2;369"
- +2 SET PRCHTP(1,5)="S X=+$P(^PRC(442,PRCHPO,1),U,15),X=$E(X,3)+$E(X,4);304"
- SET PRCHTP(1,6)="S X=""R"";370"
- SET PRCHTP(1,7)="102;344"
- +3 QUIT
- B552 ;UNPOSTED DEPOT RECEIPT CODE SHEETS (RELEASE)
- +1 SET PRCHTP(1,1)="S X=PRCHPO;5.1"
- SET PRCHTP(1,2)="107;345"
- SET PRCHTP(1,3)=".09;368"
- SET PRCHTP(1,4)="D DOCID^PRCHCS2;369"
- SET PRCHTP(1,5)="70;330"
- +2 SET PRCHTP(1,6)="S X=""R"";370"
- SET PRCHTP(1,7)="102;344"
- SET PRCHTP(1,8)="S X=PRCHN(""FMO"");305"
- SET PRCHTP(1,9)="S X=$S($D(^PRC(442,PRCHPO,11,PRCHRPT,1)):$P(^(1),U,2),1:"""");333"
- +3 QUIT
- CMDTY SET X=""
- IF PRCHCOM=8
- IF $DATA(^PRC(442,PRCHPO,17))
- IF $EXTRACT(^(17),1,2)=11
- SET X=$PIECE(PRCHRD,".",1)
- +1 QUIT
