PRCPDAPI ;WISC/RFJ-drug accountability/prime vendor (check item) ;15 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ITEM ; check line item, item master file for errors
; major errors in format or upload
I '$P(DATA,"^",2) D ERROR^PRCPDAPE("'IT1' ITEM DATA, INVOICE LINE NUMBER (piece 2) NOT DEFINED") Q
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
I $P(DATA,"^",6)'="DS" D ERROR^PRCPDAPE("'IT1' ITEM DATA, UNIT PRICE CODE (piece 6) SHOULD EQUAL 'DS' FOR DISCOUNT") Q
I $P(DATA,"^",7)'="ND" D ERROR^PRCPDAPE("'IT1' ITEM DATA, ITEM IDENTIFIER (piece 7) SHOULD EQUAL 'ND' FOR NATIONAL DRUG CODE") Q
;
; no major errors in format or upload
S LINEITEM=+$P(DATA,"^",2),NDC=$P(DATA,"^",8),VDC=$P(DATA,"^",10)
S ^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM)=+$P(DATA,"^",3)_"^"_$P(DATA,"^",4)_"^"_(+$P(DATA,"^",5))_"^"_NDC_"^"_VDC
;
; get item master file and vendor entry
D GETITEM
I 'ITEMDA S:VDC="" VDC=" " S ITEMDA=+$O(^PRC(441,"D",VDC,0)) I ITEMDA S VENDA=+$O(^PRC(441,"D",VDC,ITEMDA,0))
I 'ITEMDA S VDC="#"_VDC,ITEMDA=+$O(^PRC(441,"D",VDC,0)) I ITEMDA S VENDA=+$O(^PRC(441,"D",VDC,ITEMDA,0))
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
; check item master file errors
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
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
S $P(^TMP($J,"PRCPDAPV SET",STCTRL,"IT",LINEITEM),"^",6)=ITEMDA_"^"_VENDA
Q
;
;
GETITEM ; lookup item on ndc with all combinations
; requires ndc
; returns itemda, ndc found, vendor
N END,END0,FRO,FRO0,MID,MID0
;
S END=$E(NDC,$L(NDC)-1,$L(NDC)),FRO=$E(NDC,1,$L(NDC)-2)
S MID=$E(FRO,$L(FRO)-3,$L(FRO)),FRO=$E(FRO,1,$L(FRO)-4)
;
S FRO0=FRO,MID0=MID,END0=END
F D Q:ITEMDA
. D LOOKUP(FRO0,MID0,END0) Q:ITEMDA
. ;
. I $E(FRO0)=0 S FRO0=$E(FRO0,2,99) Q
. I $E(MID0)=0 S FRO0=FRO,MID0=$E(MID0,2,99) Q
. I $E(END0)=0 S FRO0=FRO,MID0=MID,END0=$E(END0,2,99) Q
. S ITEMDA=-1
I ITEMDA=-1 S ITEMDA=0
Q
;
;
LOOKUP(FRO,MID,END) ; lookup item by NDC (fro-mid-end)
S NDC=FRO_"-"_MID_"-"_END
S ITEMDA=+$O(^PRC(441,"F",NDC,0))
I ITEMDA S VENDA=+$O(^PRC(441,"F",NDC,ITEMDA,0))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPDAPI 2800 printed Apr 09, 2024@21:13:03 Page 2
PRCPDAPI ;WISC/RFJ-drug accountability/prime vendor (check item) ;15 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
ITEM ; check line item, item master file for errors
+1 ; major errors in format or upload
+2 IF '$PIECE(DATA,"^",2)
DO ERROR^PRCPDAPE("'IT1' ITEM DATA, INVOICE LINE NUMBER (piece 2) NOT DEFINED")
QUIT
+3 IF $DATA(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",+$PIECE(DATA,"^",2)))
DO ERROR^PRCPDAPE("'IT1' ITEM DATA, INVOICE NUMBER (piece 2) APPEARS ON THE INVOICE MORE THAN ONCE")
QUIT
+4 IF $PIECE(DATA,"^",6)'="DS"
DO ERROR^PRCPDAPE("'IT1' ITEM DATA, UNIT PRICE CODE (piece 6) SHOULD EQUAL 'DS' FOR DISCOUNT")
QUIT
+5 IF $PIECE(DATA,"^",7)'="ND"
DO ERROR^PRCPDAPE("'IT1' ITEM DATA, ITEM IDENTIFIER (piece 7) SHOULD EQUAL 'ND' FOR NATIONAL DRUG CODE")
QUIT
+6 ;
+7 ; no major errors in format or upload
+8 SET LINEITEM=+$PIECE(DATA,"^",2)
SET NDC=$PIECE(DATA,"^",8)
SET VDC=$PIECE(DATA,"^",10)
+9 SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM)=+$PIECE(DATA,"^",3)_"^"_$PIECE(DATA,"^",4)_"^"_(+$PIECE(DATA,"^",5))_"^"_NDC_"^"_VDC
+10 ;
+11 ; get item master file and vendor entry
+12 DO GETITEM
+13 IF 'ITEMDA
if VDC=""
SET VDC=" "
SET ITEMDA=+$ORDER(^PRC(441,"D",VDC,0))
IF ITEMDA
SET VENDA=+$ORDER(^PRC(441,"D",VDC,ITEMDA,0))
+14 IF 'ITEMDA
SET VDC="#"_VDC
SET ITEMDA=+$ORDER(^PRC(441,"D",VDC,0))
IF ITEMDA
SET VENDA=+$ORDER(^PRC(441,"D",VDC,ITEMDA,0))
+15 IF 'ITEMDA
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E")="ERROR: ITEM NOT STORED IN ITEM MASTER FILE (#441)."
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"E")=1
SET PRCPFERR=1
QUIT
+16 ; check item master file errors
+17 IF ITEMDA
IF $LENGTH(NDC)
SET %=+$ORDER(^PRC(441,"F",NDC,ITEMDA))
IF %
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E1")="ERROR: THE NDC ["_NDC_"] IS A DUPLICATE WITH ITEM MASTER #"_%
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"E")=1
SET PRCPFERR=1
+18 IF '$DATA(^PRC(441,ITEMDA,2,PRCPVEND,0))
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM,"E2")="ERROR: THE PRIME VENDOR IS NOT A VENDOR IN THE ITEM MASTER FILE (#441)."
SET ^TMP($JOB,"PRCPDAPV SET",STCTRL,"E")=1
SET PRCPFERR=1
+19 SET $PIECE(^TMP($JOB,"PRCPDAPV SET",STCTRL,"IT",LINEITEM),"^",6)=ITEMDA_"^"_VENDA
+20 QUIT
+21 ;
+22 ;
GETITEM ; lookup item on ndc with all combinations
+1 ; requires ndc
+2 ; returns itemda, ndc found, vendor
+3 NEW END,END0,FRO,FRO0,MID,MID0
+4 ;
+5 SET END=$EXTRACT(NDC,$LENGTH(NDC)-1,$LENGTH(NDC))
SET FRO=$EXTRACT(NDC,1,$LENGTH(NDC)-2)
+6 SET MID=$EXTRACT(FRO,$LENGTH(FRO)-3,$LENGTH(FRO))
SET FRO=$EXTRACT(FRO,1,$LENGTH(FRO)-4)
+7 ;
+8 SET FRO0=FRO
SET MID0=MID
SET END0=END
+9 FOR
Begin DoDot:1
+10 DO LOOKUP(FRO0,MID0,END0)
if ITEMDA
QUIT
+11 ;
+12 IF $EXTRACT(FRO0)=0
SET FRO0=$EXTRACT(FRO0,2,99)
QUIT
+13 IF $EXTRACT(MID0)=0
SET FRO0=FRO
SET MID0=$EXTRACT(MID0,2,99)
QUIT
+14 IF $EXTRACT(END0)=0
SET FRO0=FRO
SET MID0=MID
SET END0=$EXTRACT(END0,2,99)
QUIT
+15 SET ITEMDA=-1
End DoDot:1
if ITEMDA
QUIT
+16 IF ITEMDA=-1
SET ITEMDA=0
+17 QUIT
+18 ;
+19 ;
LOOKUP(FRO,MID,END) ; lookup item by NDC (fro-mid-end)
+1 SET NDC=FRO_"-"_MID_"-"_END
+2 SET ITEMDA=+$ORDER(^PRC(441,"F",NDC,0))
+3 IF ITEMDA
SET VENDA=+$ORDER(^PRC(441,"F",NDC,ITEMDA,0))
+4 QUIT
