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

BPSJZPR.m

Go to the documentation of this file.
  1. BPSJZPR ;BHAM ISC/CMW/LJF - Process Incoming HL7 ZPR Message ;01-DEC-2003
  1. ;;1.0;E CLAIMS MGMT ENGINE;**1,10,15,19**;JUN 2004;Build 18
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Description:
  1. ; Process incoming HL7 ZPR Messages
  1. ; Update Payer Sheet File (9002313.92)
  1. ;
  1. Q
  1. ;
  1. ; Entry point
  1. EN(BPSJEN,BPSJSEG,BPSJROOT,BPSFILE) ;
  1. ;
  1. N BPRCODE,BPSF,BPSFDIC,BPSEGID,BPORDER,BPMODE,BPNOTES,BPSETID
  1. N FLN,FLNSC,FLNPN,FLNSPEC
  1. N DIE,DIC,DLAYGO,DR,DA,DINUM
  1. N C,X,Y,NCNT,BPND
  1. ;
  1. I $G(BPSJEN),$G(BPSJROOT)]"",$G(BPSFILE)]"",$D(BPSJSEG)
  1. E Q ; invalid info
  1. ;
  1. S BPRCODE=$$ZPR(),DIE=$G(BPSJROOT),C=","
  1. ;
  1. I BPRCODE,BPSEGID,BPORDER
  1. E Q
  1. ;
  1. S BPSF=DIE_BPSJEN_C_BPSEGID_",0)"
  1. I '$D(@BPSF) D
  1. . S FLNSPEC=$$GET1^DID(BPSFILE,BPSEGID,"","SPECIFIER")
  1. . S @BPSF=U_FLNSPEC_U_U
  1. ;
  1. S (X,DINUM)=BPORDER
  1. S DA(1)=BPSJEN,DIC=DIE_BPSJEN_C_BPSEGID_C
  1. S DIC(0)="L",(DIC("P"),DLAYGO)=FLN
  1. D ^DIC
  1. ;
  1. S DA=+Y
  1. S DIE=DIC
  1. S DR=".02////"_BPRCODE_";.03////"_BPMODE
  1. D ^DIE
  1. ;
  1. S BPSFDIC=DIC ; save dictionary ID
  1. ; NOTES
  1. I $D(BPSJSEG(8)) D
  1. . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"
  1. . I '$D(@BPSF) S @BPSF=U_FLNPN_U_U
  1. . S BPND="BPSJSEG(7,99)",NCNT=0
  1. . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D
  1. .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"
  1. .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=2,(NCNT,DA)=NCNT+1
  1. .. K DR S DR=".01////"_@BPND
  1. .. D ^DIE
  1. K BPSJSEG(8) ; kill 8 so $Q of 7 won't find it
  1. ;
  1. ; Special Code
  1. I $D(BPSJSEG(7)) D
  1. . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"
  1. . I '$D(@BPSF) S @BPSF=U_FLNSC_U_U
  1. . S BPND="BPSJSEG(6,99)",NCNT=0
  1. . F S BPND=$Q(@BPND) Q:BPND="" I $G(@BPND)]"" D
  1. .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"
  1. .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=1,(NCNT,DA)=NCNT+1
  1. .. K DR S DR=".01////"_@BPND
  1. .. D ^DIE
  1. Q
  1. ;
  1. ZPR() ; Validate Fields and Initialize ZPR variables
  1. N RCODE,WDATA
  1. ;
  1. ; Reject reasons: 1=Missing ,2=Invalid
  1. ; ^TMP($J,"BPSJ-ERROR" is killed before and after it is used in BPSJHLT
  1. ;
  1. S BPSETID=$G(BPSJSEG(2))
  1. ;
  1. S BPSEGID=$G(BPSJSEG(3))
  1. I BPSEGID="" S BPSEGID=0 D
  1. . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-1,"_BPSETID
  1. E S BPSEGID=$G(ZPRS(BPSEGID)) D
  1. . I 'BPSEGID S BPSEGID=0 D Q
  1. .. S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-2,"_BPSETID
  1. . ;
  1. . S FLN=$P(BPSEGID,U,2)
  1. . S FLNSC=$P(BPSEGID,U,3)
  1. . S FLNPN=$P(BPSEGID,U,4)
  1. . S BPSEGID=+BPSEGID
  1. ;
  1. S RCODE=$$GETPTR($$TRIM^XLFSTR($G(BPSJSEG(4))))
  1. I 'RCODE S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-2,"_BPSETID
  1. I $G(BPSJSEG(4))="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-1,"_BPSETID
  1. ;
  1. S BPORDER=$G(BPSJSEG(5))
  1. I BPORDER="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,4)="V634,"_BPSETID
  1. ;
  1. S BPMODE=$G(BPSJSEG(6))
  1. ;
  1. I BPMODE'="X",BPMODE'="S" D
  1. . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,5)="V635,"_BPSETID
  1. ;
  1. I '$L($G(BPSJSEG(7))),$D(BPSJSEG(7))'>1 K BPSJSEG(7)
  1. E D ;NOTES(.BPSJSEG(7))
  1. . K WDATA M WDATA(7)=BPSJSEG(7) D NOTES(.WDATA)
  1. . K BPSJSEG(7) M BPSJSEG(7)=WDATA K WDATA
  1. ;
  1. ; flag error if processing mode="X" and no special code
  1. I BPMODE="X",'$D(BPSJSEG(7)) S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,6)="V636,"_BPSETID
  1. ;
  1. I '$L($G(BPSJSEG(8))),$D(BPSJSEG(8))'>1 K BPSJSEG(8)
  1. E D ;NOTES(.BPSJSEG(8))
  1. . K WDATA M WDATA(8)=BPSJSEG(8) D NOTES(.WDATA)
  1. . K BPSJSEG(8) M BPSJSEG(8)=WDATA K WDATA
  1. ;
  1. Q RCODE
  1. ;
  1. NOTES(ARRAYIN,TRCH) ; fProgrammer Notes - Special Code handler
  1. ;
  1. N II,ODAT,NODENM
  1. N ISDATA,ISDATA1,ISDATA2,ISDATA3
  1. ;
  1. I '$D(TRCH) D ; apply standard Vista/Vitria "Free Text" de-encoding
  1. . S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\"
  1. . S TRCH("\T\")="&",TRCH("\S\")="^"
  1. . S TRCH("\.b")=1,TRCH("\.br\")=1
  1. ;
  1. S NODENM="ARRAYIN"
  1. ;
  1. S (ODAT,ISDATA1)=""
  1. F S NODENM=$Q(@NODENM) Q:NODENM="" S ISDATA=@NODENM D
  1. . ; clean up partial string if any
  1. . I $L(ISDATA1) D I '$L(ISDATA) Q
  1. .. S ISDATA1=ISDATA1_$E(ISDATA,1,10)
  1. .. S ISDATA3=$$DECODE(ISDATA1,.TRCH,.ODAT,.ISDATA2)
  1. .. S $E(ISDATA,1,10)=ISDATA2
  1. . ;
  1. . S ISDATA2=$$DECODE(ISDATA,.TRCH,.ODAT,.ISDATA1)
  1. ;
  1. S ODAT=ODAT_ISDATA1 D NWNODE(.ODAT) K ARRAYIN M ARRAYIN=ODAT
  1. Q
  1. ;
  1. NWNODE(FREERAY) ; build free text array
  1. N CNT
  1. S CNT=1+$O(FREERAY(""),-1),FREERAY(CNT)=FREERAY,FREERAY=""
  1. Q
  1. ;
  1. DECODE(INSTR,TCH,WDAT,INSTR1) ;
  1. ; INSTR - Input string
  1. ; TCH - translation array
  1. ; WDAT - Output in a Vista compliant "Free Text" array
  1. ; INSTR1 - Remainder of text when last or
  1. ; second to last INSTR char = "\"
  1. ;Development Note:
  1. ;\.br\ - removed and new node created
  1. ;\E\.br\E\ = \.br\ - (no further translation)
  1. ;non-printable character translation not supported
  1. ;Output Array nodes will contain no more than 200 characters each
  1. ;
  1. N II,CH
  1. S INSTR1="",WDAT=$G(WDAT)
  1. F II=1:1:$L(INSTR) S CH=$E(INSTR,II) D:CH="\" S WDAT=WDAT_CH I $L(WDAT)>199 D NWNODE(.WDAT)
  1. . ;
  1. . ; Partial TCH string, if \.br\ (CR-LF) translation allowed
  1. . I $L($E(INSTR,II,II+2))<3,$G(TCH("\.br\")) D Q
  1. .. S INSTR1=$E(INSTR,II,II+2),II=$L(INSTR),CH=""
  1. . ;
  1. . I '$D(TCH($E(INSTR,II,II+2))) Q ; not one we're interested in
  1. . I +$G(TCH($E(INSTR,II,II+2))) D Q ; \.br\ to <CR-LF> conversion
  1. .. I (II+4)>$L(INSTR) S INSTR1=$E(INSTR,II,$L(INSTR)),II=$L(INSTR),CH="" Q
  1. .. I +$G(TCH($E(INSTR,II,II+4))) S II=II+4,CH="" D NWNODE(.WDAT)
  1. . ;
  1. . S CH=TCH($E(INSTR,II,II+2)),II=II+2 ; std conversion
  1. Q WDAT ; Return top node of WDAT - for strings less than 200 characters
  1. ;
  1. GETPTR(BPDAT) ; Get pointer into BPS NCPDP FIELD DEFS
  1. N BPSFNM,BPSFNO,BPSIX,BPSIXALT,BPSFX,BPNAMIX,BPNUMIX,BPSFNOCK
  1. ;
  1. S BPSFNM=$P($G(BPDAT),"-",2),BPSFNO=$P($G(BPDAT),"-") ; allow for alphanumeric NCPDP number - BPS*1*15
  1. I BPSFNM]"",BPSFNO]"" S (BPSIX,BPSIXALT)=0,BPSFX=BPSFNO_U_BPSFNM
  1. E Q 0
  1. S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,""))
  1. S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,""))
  1. ;
  1. ;-if NAME and NUMBER point to the same IEN (but not 0)
  1. I BPNAMIX,BPNUMIX=BPNAMIX Q BPNAMIX
  1. ;
  1. ;-else might be in another node of the "D" x-ref
  1. I BPNAMIX,BPNUMIX F D Q:BPSIX Q:'BPNAMIX
  1. . S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,BPNAMIX))
  1. . I BPNUMIX=BPNAMIX S BPSIX=BPNAMIX
  1. ;
  1. ;-If not found, try "B" x-ref value
  1. I 'BPSIX,BPNUMIX D
  1. . I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX Q
  1. . I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX Q
  1. . ;
  1. . ;-try additional "B" x-ref's for this NUMBER
  1. . F D Q:BPSIX Q:'BPNUMIX
  1. .. S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,BPNUMIX))
  1. .. I BPNUMIX D
  1. ... I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX
  1. ... I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX
  1. ;
  1. ;-Last resort - go through all iens'
  1. I 'BPSIX S BPNUMIX=0 F D Q:BPSIX Q:'BPNUMIX
  1. . S BPNUMIX=$O(^BPSF(9002313.91,BPNUMIX))
  1. . I BPNUMIX,+$G(^BPSF(9002313.91,BPNUMIX,0))[BPSFNO D
  1. .. S BPSFNOCK=+$G(^BPSF(9002313.91,BPNUMIX,0))
  1. .. ; Note: Special coding included for BPSFNO of 498 (498.nn)
  1. .. I BPSFNOCK'=BPSFNO,$P(BPSFNOCK,".")'=498 Q
  1. .. I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX
  1. .. I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX
  1. ;
  1. Q BPSIX
  1. ;
  1. INITZPRS(ZPRS) ;BPSEGID^FLN^FLNSC^FLNPN
  1. S ZPRS(0)="100^9002313.9205^9002313.92051^9002313.92052"
  1. S ZPRS(1)="110^9002313.9206^9002313.92061^9002313.92062"
  1. S ZPRS(2)="140^9002313.9209^9002313.92091^9002313.92092"
  1. S ZPRS(3)="150^9002313.921^9002313.9211^9002313.9212"
  1. S ZPRS(4)="120^9002313.9207^9002313.92071^9002313.92072"
  1. S ZPRS(5)="160^9002313.9213^9002313.92131^9002313.92132"
  1. S ZPRS(6)="170^9002313.9214^9002313.92141^9002313.92142"
  1. S ZPRS(7)="130^9002313.9208^9002313.92081^9002313.92082"
  1. S ZPRS(8)="180^9002313.9215^9002313.92151^9002313.92152"
  1. S ZPRS(9)="200^9002313.9217^9002313.92171^9002313.92172"
  1. S ZPRS(10)="210^9002313.9218^9002313.92181^9002313.92182"
  1. S ZPRS(11)="190^9002313.9216^9002313.92161^9002313.92162"
  1. S ZPRS(12)="220^9002313.9219^9002313.92191^9002313.92192"
  1. S ZPRS(13)="230^9002313.922^9002313.9221^9002313.9222"
  1. S ZPRS(14)="240^9002313.9223^9002313.92231^9002313.92232"
  1. S ZPRS(15)="250^9002313.9224^9002313.92241^9002313.92242"
  1. S ZPRS(16)="260^9002313.9225^9002313.92251^9002313.92252"
  1. ;BPS*1*15 - Purchaser and Provider segment added for D.1 - D.9 version
  1. S ZPRS(17)="270^9002313.9227^9002313.92271^9002313.92272"
  1. S ZPRS(18)="280^9002313.9228^9002313.92281^9002313.92282"
  1. ;BPS*1*19 - Intermediary and Last Known 4Rx segments added for E.0 - E.6 version
  1. S ZPRS(19)="290^9002313.9229^9002313.92291^9002313.92292"
  1. S ZPRS(37)="300^9002313.923^9002313.9231^9002313.9232"
  1. Q