Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCVIT

PRCVIT.m

Go to the documentation of this file.
  1. PRCVIT ;WOIFO/DST - Send ITEM master file update to DYNAMED ; 3/2/05 5:07pm
  1. ;;5.1;IFCAP;**81**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. Q
  1. NITECHK ;
  1. ; Once a day check
  1. ; Compare a checksum and set a record to update
  1. ;
  1. ; If not DynaMed, don't do it
  1. Q:'$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")
  1. ;
  1. N PRCND,PRCVL,PRCVP,PRCVAL,PRCVIT,PRCVN,PRCVSTN
  1. N PRCVFN
  1. S PRCVP=67280421310721,PRCVN=99999
  1. S PRCVFN=$O(^PRCV(414.04,"D","ITEM",0))
  1. ; Clear old flag
  1. K ^TMP("PRCVIT",$J)
  1. S PRCVSTN=$$GET1^DIQ(4,$$KSP^XUPARAM("INST")_",",99)
  1. F S PRCVN=$O(^PRC(441,PRCVN)) Q:'PRCVN D
  1. . S PRCVAL=$$CHKSUM()
  1. . ; Compare to existing CheckSum
  1. . ; Kick off HL7 interface message to DynaMed, if not the same
  1. . I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,PRCVFN,1,PRCVN,0)),U,2) D
  1. .. S ^PRCV(414.04,PRCVFN,1,PRCVN,0)=PRCVN_U_PRCVAL
  1. .. D GETDATA(PRCVN)
  1. .. I $D(^TMP("PRCVIT",$J,PRCVN)) D EN^PRCVIMF(PRCVN)
  1. .. Q
  1. . Q
  1. K ^TMP("PRCVIT",$J)
  1. Q
  1. ;
  1. ONECHK(PRCVN) ;
  1. ; Checksum to one ITEM only
  1. Q:PRCVN<99999
  1. N PRCND,PRCVL,PRCVFN,PRCVP,PRCVAL,PRCVIT
  1. K ^TMP("PRCVIT",$J,PRCVN)
  1. S PRCVP=67280421310721
  1. S PRCVFN=$O(^PRCV(414.04,"D","ITEM",0))
  1. S PRCVAL=$$CHKSUM()
  1. ; If checksum not equal 0, get data to DynaMed
  1. I PRCVAL,PRCVAL'=$P($G(^PRCV(414.04,PRCVFN,1,PRCVN,0)),U,2) D
  1. . D GETDATA(PRCVN)
  1. . S ^PRCV(414.04,PRCVFN,1,PRCVN,0)=PRCVN_U_PRCVAL
  1. . I $D(^TMP("PRCVIT",$J,PRCVN)) D EN^PRCVIMF(PRCVN)
  1. . Q
  1. K ^TMP("PRCVIT",$J,PRCVN)
  1. Q
  1. INIT ;
  1. ; Initialize checksum global at installation
  1. N PRCVN,PRCVP,RESULT,FDA
  1. ;
  1. S FDA(414.04,"?+1,",.01)="ITEM"
  1. S FDA(414.04,"?+1,",.02)=441
  1. S FDA(414.04,"?+1,",.03)="Item file checksum (on partial field)"
  1. D UPDATE^DIE("E","FDA","RESULT")
  1. S PRCVP=67280421310721,PRCVN=99999
  1. F S PRCVN=$O(^PRC(441,PRCVN)) Q:'PRCVN D
  1. . S FDA(414.41,"?+1,"_RESULT(1)_",",.01)=PRCVN
  1. . S FDA(414.41,"?+1,"_RESULT(1)_",",1)=$$CHKSUM()
  1. . D UPDATE^DIE("E","FDA")
  1. Q
  1. ;
  1. CHKSUM() ;
  1. N PRCVST
  1. S PRCVAL=0
  1. ; Node 0
  1. S PRCVIT=$G(^PRC(441,PRCVN,0))
  1. ; Piece 1 - ITEM Number
  1. ; Piece 2 - ITEM Short Description
  1. ; Piece 3 - FSC - Federal Supply Classification
  1. ; Piece 4 - Last vendor ordered
  1. ; Piece 5 - NSN - National Stock Number
  1. ; Piece 6 - Case/Cart Tray/instrument kit
  1. ; Piece 8 - Mandatory Source
  1. ; Piece 9 - Date Item Created
  1. ; Piece 10 - BOC
  1. ; Piece 11 - DUZ
  1. ; Piece 13 - Reusable Item
  1. ; Piece 14 - Hazardous material
  1. ; Piece 15 - NIF ITEM number
  1. S PRCVI=0
  1. F PRCVI=1:1:6,8:1:11,13:1:15 D
  1. . S PRCVST=$P(PRCVIT,U,PRCVI)
  1. . S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. . Q
  1. ; Node 1 - Description
  1. ;
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVN,1,PRCVI)) Q:'PRCVI D
  1. . S PRCVST=^PRC(441,PRCVN,1,PRCVI,0)
  1. . S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. . Q
  1. ; Node 2 - Vendors
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVN,2,PRCVI)) Q:'PRCVI D
  1. . S PRCVST=^PRC(441,PRCVN,2,PRCVI,0)
  1. . S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. . Q
  1. ; Node 3
  1. ; Piece 1 - Inactivated ITEM?
  1. ; Piece 2 - Date Inactivated
  1. ; Piece 3 - Inactivated By
  1. ; Piece 4 - Replacement Item
  1. ; Piece 5 - MFG Part No.
  1. ; Piece 6 - NSN Verified
  1. ; Piece 7 - Food Group
  1. ; Piece 8 - SKU
  1. ; Piece 9 - Drug Type Code
  1. ; Piece 10 - SIC Code
  1. ;
  1. ; Check the whole node 3
  1. ;
  1. S PRCVST=$G(^PRC(441,PRCVN,3))
  1. I PRCVST]"" S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. ;
  1. ; Node 4 - Fund Control Point
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVN,4,PRCVI)) Q:'PRCVI D
  1. . S PRCVST=$G(^PRC(441,PRCVN,4,PRCVI,0))
  1. . S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. . Q
  1. ; Node 6 - Pre_NIF Long Description
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVN,6,PRCVI)) Q:'PRCVI D
  1. . S PRCVST=^PRC(441,PRCVN,6,PRCVI,0)
  1. . S PRCVAL=$$CKINC(PRCVAL,PRCVST)
  1. . Q
  1. ;
  1. Q PRCVAL
  1. ;
  1. GETDATA(PRCVNM) ;
  1. ; Get all field required,
  1. ; Node 0
  1. ;
  1. N PRCVND,PRCVI,PRCVJ,PRCVCON,PRCVERR
  1. S PRCVERR=0
  1. S PRCVIT=$G(^PRC(441,PRCVNM,0))
  1. S PRCVND=$P(PRCVIT,U,1,6)
  1. S PRCVJ=6
  1. F PRCVI=8:1:11,13,14,15 D
  1. . S PRCVJ=PRCVJ+1
  1. . S $P(PRCVND,U,PRCVJ)=$P(PRCVIT,U,PRCVI)
  1. . Q
  1. S $P(PRCVND,U,11)="N"
  1. S:$P(PRCVIT,U,13)="Y"!("y") $P(PRCVND,U,11)="Y"
  1. S ^TMP("PRCVIT",$J,PRCVNM,0)=PRCVND
  1. ;
  1. ; Node 1 - Description
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVNM,1,PRCVI)) Q:'PRCVI D
  1. . S ^TMP("PRCVIT",$J,PRCVNM,1,PRCVI)=^PRC(441,PRCVNM,1,PRCVI,0)
  1. . Q
  1. ; Node 2 - Vendors
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVNM,2,PRCVI)) Q:'PRCVI D
  1. . S PRCVND=^PRC(441,PRCVNM,2,PRCVI,0)
  1. . ; Check if the contract exists in Vendor File
  1. . ; If not, send a message to Control Point officer
  1. . I $P(PRCVND,U)']"" S $P(PRCVND,U)=0
  1. . I $P(PRCVND,U,3)']"" S $P(PRCVND,U,3)=0
  1. . S PRCVCON=$G(^PRC(440,$P(PRCVND,U),4,$P(PRCVND,U,3),0))
  1. . I $P(PRCVND,U)>0,($P(PRCVND,U,3)>0),($P(PRCVCON,U)']"") D
  1. .. S PRCVERR=PRCVERR+1
  1. .. S PRCVERR(PRCVERR)="Contract # "_$P(PRCVND,U,3)_" of VENDOR - "_$P(PRCVND,U)_", "_$P($G(^PRC(440,$P(PRCVND,U),0)),U)_", for ITEM # "_PRCVNM_" does not exist in IFCAP Vendor file."
  1. .. S $P(PRCVND,U,3)=""
  1. .. Q
  1. . ; Check exp. date of contract, QUIT if expired more than 365 days
  1. . I $P(PRCVCON,U,3)]"",($P(PRCVCON,U,3)<$$FMADD^XLFDT(DT,-365)) S $P(PRCVND,U,3)=""
  1. . ; Conversion on PRCVND
  1. . S:$P(PRCVND,U,2)="" $P(PRCVND,U,2)=0
  1. . S:$P(PRCVND,U,8)="" $P(PRCVND,U,8)=1
  1. . S ^TMP("PRCVIT",$J,PRCVNM,2,PRCVI)=PRCVND
  1. . Q
  1. ; Node 3
  1. I $D(^PRC(441,PRCVNM,3)) S ^TMP("PRCVIT",$J,PRCVNM,3)=^PRC(441,PRCVNM,3)
  1. ;
  1. ; Node 4 - Fund Control Point
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVNM,4,PRCVI)) Q:'PRCVI D
  1. . S PRCVND=^PRC(441,PRCVNM,4,PRCVI,0)
  1. . S $P(PRCVND,U)=$E($P(PRCVND,U),4,7)
  1. . S ^TMP("PRCVIT",$J,PRCVNM,4,PRCVI)=PRCVND
  1. . Q
  1. ;
  1. ; Node 6 - Pre_NIF Long Description
  1. S PRCVI=0
  1. F S PRCVI=$O(^PRC(441,PRCVNM,6,PRCVI)) Q:'PRCVI D
  1. . S ^TMP("PRCVIT",$J,PRCVNM,6,PRCVI)=^PRC(441,PRCVNM,6,PRCVI,0)
  1. . Q
  1. ; If there are error(s), inform user by e-mail
  1. I PRCVERR>0 D XMD
  1. Q
  1. ;
  1. XMD ; Send a message to Control Point officer/clerk for data mismatch
  1. ;
  1. N XMDUZ,XMMG,XMSUB,XMTEXT,XMY,XMZ
  1. S XMSUB="Inventory System ITEM Update Info "_$$HTE^XLFDT($H)
  1. S XMDUZ="IFCAP/COTS Inventory Interface"
  1. S XMTEXT="PRCVERR("
  1. ; S PRCVERR(1)="Contract "_PRCVCON_" of VENDOR # "_$P(PRCVND,U)_" for ITEM # "_PRCVNM_" does not existed in IFCAP Vendor file."
  1. S XMY("G.PRCV Item Vendor Edits")=""
  1. D ^XMD
  1. Q
  1. ;
  1. CKINC(PRCVF,PRCVS) ;incremental checksum
  1. N LEN,FIB,C,I,PRCVAL,TEST
  1. S TEST=PRCVF
  1. S PRCVF=+$G(PRCVF)
  1. S PRCVS=$G(PRCVS)
  1. ;No change on null input
  1. Q:PRCVS="" PRCVF
  1. S LEN=$L(PRCVS)
  1. S PRCVAL=0
  1. S FIB(1)=1,FIB(2)=1
  1. F I=1:1:LEN D
  1. .S C=$E(PRCVS,I)
  1. .S:I>2 FIB(I)=FIB(I-1)+FIB(I-2)#2147483647
  1. .S PRCVAL=(PRCVF+PRCVAL+($A(C)*FIB(I)))#PRCVP
  1. Q PRCVAL