source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPDAPI.m@ 1093

Last change on this file since 1093 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1PRCPDAPI ;WISC/RFJ-drug accountability/prime vendor (check item) ;15 Mar 94
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7ITEM ; check line item, item master file for errors
8 ; major errors in format or upload
9 I '$P(DATA,"^",2) D ERROR^PRCPDAPE("'IT1' ITEM DATA, INVOICE LINE NUMBER (piece 2) NOT DEFINED") Q
10 I $D(^TMP($J,"PRCPDAPV SET",STCTRL,"IT",+$P(DATA,"^",2))) D ERROR^PRCPDAPE("'IT1' ITEM DATA, INVOICE NUMBER (piece 2) APPEARS ON THE INVOICE MORE THAN ONCE") Q
11 I $P(DATA,"^",6)'="DS" D ERROR^PRCPDAPE("'IT1' ITEM DATA, UNIT PRICE CODE (piece 6) SHOULD EQUAL 'DS' FOR DISCOUNT") Q
12 I $P(DATA,"^",7)'="ND" D ERROR^PRCPDAPE("'IT1' ITEM DATA, ITEM IDENTIFIER (piece 7) SHOULD EQUAL 'ND' FOR NATIONAL DRUG CODE") Q
13 ;
14 ; no major errors in format or upload
15 S LINEITEM=+$P(DATA,"^",2),NDC=$P(DATA,"^",8),VDC=$P(DATA,"^",10)
16 S ^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM)=+$P(DATA,"^",3)_"^"_$P(DATA,"^",4)_"^"_(+$P(DATA,"^",5))_"^"_NDC_"^"_VDC
17 ;
18 ; get item master file and vendor entry
19 D GETITEM
20 I 'ITEMDA S:VDC="" VDC=" " S ITEMDA=+$O(^PRC(441,"D",VDC,0)) I ITEMDA S VENDA=+$O(^PRC(441,"D",VDC,ITEMDA,0))
21 I 'ITEMDA S VDC="#"_VDC,ITEMDA=+$O(^PRC(441,"D",VDC,0)) I ITEMDA S VENDA=+$O(^PRC(441,"D",VDC,ITEMDA,0))
22 I 'ITEMDA S ^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E")="ERROR: ITEM NOT STORED IN ITEM MASTER FILE (#441).",^TMP($J,"PRCPDAPV SET",STCTRL,"E")=1,PRCPFERR=1 Q
23 ; check item master file errors
24 I ITEMDA,$L(NDC) S %=+$O(^PRC(441,"F",NDC,ITEMDA)) I % S ^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E1")="ERROR: THE NDC ["_NDC_"] IS A DUPLICATE WITH ITEM MASTER #"_%,^TMP($J,"PRCPDAPV SET",STCTRL,"E")=1,PRCPFERR=1
25 I '$D(^PRC(441,ITEMDA,2,PRCPVEND,0)) S ^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E2")="ERROR: THE PRIME VENDOR IS NOT A VENDOR IN THE ITEM MASTER FILE (#441).",^TMP($J,"PRCPDAPV SET",STCTRL,"E")=1,PRCPFERR=1
26 S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM),"^",6)=ITEMDA_"^"_VENDA
27 Q
28 ;
29 ;
30GETITEM ; lookup item on ndc with all combinations
31 ; requires ndc
32 ; returns itemda, ndc found, vendor
33 N END,END0,FRO,FRO0,MID,MID0
34 ;
35 S END=$E(NDC,$L(NDC)-1,$L(NDC)),FRO=$E(NDC,1,$L(NDC)-2)
36 S MID=$E(FRO,$L(FRO)-3,$L(FRO)),FRO=$E(FRO,1,$L(FRO)-4)
37 ;
38 S FRO0=FRO,MID0=MID,END0=END
39 F D Q:ITEMDA
40 . D LOOKUP(FRO0,MID0,END0) Q:ITEMDA
41 . ;
42 . I $E(FRO0)=0 S FRO0=$E(FRO0,2,99) Q
43 . I $E(MID0)=0 S FRO0=FRO,MID0=$E(MID0,2,99) Q
44 . I $E(END0)=0 S FRO0=FRO,MID0=MID,END0=$E(END0,2,99) Q
45 . S ITEMDA=-1
46 I ITEMDA=-1 S ITEMDA=0
47 Q
48 ;
49 ;
50LOOKUP(FRO,MID,END) ; lookup item by NDC (fro-mid-end)
51 S NDC=FRO_"-"_MID_"-"_END
52 S ITEMDA=+$O(^PRC(441,"F",NDC,0))
53 I ITEMDA S VENDA=+$O(^PRC(441,"F",NDC,ITEMDA,0))
54 Q
Note: See TracBrowser for help on using the repository browser.