source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSJZPR.m@ 1073

BPSJZPR ;BHAM ISC/CMW/LJF - Process Incoming HL7 ZPR Message ;01-DEC-2003

 ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004

 ;;Per VHA Directive 10-93-142, this routine should not be modified.

 ;

 ; Description:

 ; Process incoming HL7 ZPR Messages

 ; Update Payer Sheet File (9002313.92)

 ;

 Q

 ;

 ; Entry point

EN(BPSJEN,BPSJSEG,BPSJROOT,BPSFILE) ;

 ;

 N BPRCODE,BPSF,BPSFDIC,BPSEGID,BPORDER,BPMODE,BPNOTES,BPSETID

 N FLN,FLNSC,FLNPN,FLNSPEC

 N DIE,DIC,DLAYGO,DR,DA,DINUM

 N C,X,Y,NCNT,BPND

 ;

 I $G(BPSJEN),$G(BPSJROOT)]"",$G(BPSFILE)]"",$D(BPSJSEG)

 E  Q   ; invalid info

 ;

 S BPRCODE=$$ZPR(),DIE=$G(BPSJROOT),C=","

 ;

 I BPRCODE,BPSEGID,BPORDER

 E  Q

 ;

 S BPSF=DIE_BPSJEN_C_BPSEGID_",0)"

 I '$D(@BPSF) D

 . S FLNSPEC=$$GET1^DID(BPSFILE,BPSEGID,"","SPECIFIER")

 . S @BPSF=U_FLNSPEC_U_U

 ;

 S (X,DINUM)=BPORDER

 S DA(1)=BPSJEN,DIC=DIE_BPSJEN_C_BPSEGID_C

 S DIC(0)="L",(DIC("P"),DLAYGO)=FLN

 D ^DIC

 ;

 S DA=+Y

 S DIE=DIC

 S DR=".02////"_BPRCODE_";.03////"_BPMODE

 D ^DIE

 ;

 S BPSFDIC=DIC ; save dictionary ID

 ; NOTES

 I $D(BPSJSEG(8)) D

 . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"

 . I '$D(@BPSF) S @BPSF=U_FLNPN_U_U

 . S BPND="BPSJSEG(7,99)",NCNT=0

 . F  S BPND=$Q(@BPND) Q:BPND=""  I $G(@BPND)]"" D

 .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",2,",BPSF=DIE_"0)"

 .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=2,(NCNT,DA)=NCNT+1

 .. K DR S DR=".01////"_@BPND

 .. D ^DIE

 K BPSJSEG(8) ; kill 8 so $Q of 7 won't find it

 ;

 ; Special Code

 I $D(BPSJSEG(7)) D

 . S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"

 . I '$D(@BPSF) S @BPSF=U_FLNSC_U_U

 . S BPND="BPSJSEG(6,99)",NCNT=0

 . F  S BPND=$Q(@BPND) Q:BPND=""  I $G(@BPND)]"" D

 .. S DIC=BPSFDIC,DIE=BPSFDIC_BPORDER_",1,",BPSF=DIE_"0)"

 .. K DA S DA(4)=BPSJEN,DA(3)=BPSEGID,DA(2)=BPORDER,DA(1)=1,(NCNT,DA)=NCNT+1

 .. K DR S DR=".01////"_@BPND

 .. D ^DIE

 Q

 ;

ZPR() ; Validate Fields and Initialize ZPR variables

 N RCODE,WDATA

 ;

 ; Reject reasons: 1=Missing ,2=Invalid

 ;

 S BPSETID=$G(BPSJSEG(2))

 ;

 S BPSEGID=$G(BPSJSEG(3))

 I BPSEGID="" S BPSEGID=0 D

 . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-1,"_BPSETID

 E  S BPSEGID=$G(ZPRS(BPSEGID)) D

 . I 'BPSEGID S BPSEGID=0 D  Q

 .. S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,2)="V632-2,"_BPSETID

 . ;

 . S FLN=$P(BPSEGID,U,2)

 . S FLNSC=$P(BPSEGID,U,3)

 . S FLNPN=$P(BPSEGID,U,4)

 . S BPSEGID=+BPSEGID

 ;

 S RCODE=$$GETPTR($G(BPSJSEG(4)))

 I 'RCODE S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-2,"_BPSETID

 I $G(BPSJSEG(4))="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,3)="V633-1,"_BPSETID

 ;

 S BPORDER=$G(BPSJSEG(5))

 I BPORDER="" S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,4)="V634,"_BPSETID

 ;

 S BPMODE=$G(BPSJSEG(6))

 ;

 I BPMODE'="X",BPMODE'="S" D

 . S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,5)="V635,"_BPSETID

 ;

 I '$L($G(BPSJSEG(7))),$D(BPSJSEG(7))'>1 K BPSJSEG(7)

 E  D     ;NOTES(.BPSJSEG(7))

 . K WDATA M WDATA(7)=BPSJSEG(7) D NOTES(.WDATA)

 . K BPSJSEG(7) M BPSJSEG(7)=WDATA K WDATA

 ;

 ; flag error if processing mode="X" and no special code

 I BPMODE="X",'$D(BPSJSEG(7)) S ^TMP($J,"BPSJ-ERROR","ZPR",BPSETID,6)="V636,"_BPSETID

 ;

 I '$L($G(BPSJSEG(8))),$D(BPSJSEG(8))'>1 K BPSJSEG(8)

 E  D   ;NOTES(.BPSJSEG(8))

 . K WDATA M WDATA(8)=BPSJSEG(8) D NOTES(.WDATA)

 . K BPSJSEG(8) M BPSJSEG(8)=WDATA K WDATA

 ;

 Q RCODE

 ;

NOTES(ARRAYIN,TRCH) ; fProgrammer Notes - Special Code handler

 ;

 N II,ODAT,NODENM

 N ISDATA,ISDATA1,ISDATA2,ISDATA3

 ;

 I '$D(TRCH) D   ; apply standard Vista/Vitria "Free Text" de-encoding

 . S TRCH("\F\")="|",TRCH("\R\")="~",TRCH("\E\")="\"

 . S TRCH("\T\")="&",TRCH("\S\")="^"

 . S TRCH("\.b")=1,TRCH("\.br\")=1

 ;

 S NODENM="ARRAYIN"

 ;

 S (ODAT,ISDATA1)=""

 F  S NODENM=$Q(@NODENM) Q:NODENM=""  S ISDATA=@NODENM D

 . ; clean up partial string if any

 . I $L(ISDATA1) D  I '$L(ISDATA) Q

 .. S ISDATA1=ISDATA1_$E(ISDATA,1,10)

 .. S ISDATA3=$$DECODE(ISDATA1,.TRCH,.ODAT,.ISDATA2)

 .. S $E(ISDATA,1,10)=ISDATA2

 . ;

 . S ISDATA2=$$DECODE(ISDATA,.TRCH,.ODAT,.ISDATA1)

 ;

 S ODAT=ODAT_ISDATA1 D NWNODE(.ODAT) K ARRAYIN M ARRAYIN=ODAT

 Q

 ;

NWNODE(FREERAY) ; build free text array

 N CNT

 S CNT=1+$O(FREERAY(""),-1),FREERAY(CNT)=FREERAY,FREERAY=""

 Q

 ;

DECODE(INSTR,TCH,WDAT,INSTR1) ;

 ; INSTR - Input string

 ; TCH   - translation array

 ; WDAT  - Output in a Vista compliant "Free Text" array

 ; INSTR1 - Remainder of text when last or

 ;          second to last INSTR char = "\"

 ;Development Note:

 ;\.br\ - removed and new node created

 ;\E\.br\E\ = \.br\ - (no further translation)

 ;non-printable character translation not supported

 ;Output Array nodes will contain no more than 200 characters each

 ;

 N II,CH

 S INSTR1="",WDAT=$G(WDAT)

 F II=1:1:$L(INSTR) S CH=$E(INSTR,II) D:CH="\"  S WDAT=WDAT_CH I $L(WDAT)>199 D NWNODE(.WDAT)

 . ;

 . ;  Partial TCH string, if \.br\ (CR-LF) translation allowed

 . I $L($E(INSTR,II,II+2))<3,$G(TCH("\.br\")) D  Q

 .. S INSTR1=$E(INSTR,II,II+2),II=$L(INSTR),CH=""

 . ;

 . I '$D(TCH($E(INSTR,II,II+2))) Q     ; not one we're interested in

 . I +$G(TCH($E(INSTR,II,II+2))) D  Q  ; \.br\ to <CR-LF> conversion

 .. I (II+4)>$L(INSTR) S INSTR1=$E(INSTR,II,$L(INSTR)),II=$L(INSTR),CH="" Q

 .. I +$G(TCH($E(INSTR,II,II+4))) S II=II+4,CH="" D NWNODE(.WDAT)

 . ;

 . S CH=TCH($E(INSTR,II,II+2)),II=II+2  ; std conversion

 Q WDAT   ; Return top node of WDAT - for strings less than 200 characters

 ;

GETPTR(BPDAT) ; Get pointer into BPS NCPDP FIELD DEFS

 N BPSFNM,BPSFNO,BPSIX,BPSIXALT,BPSFX,BPNAMIX,BPNUMIX,BPSFNOCK

 ;

 S BPSFNM=$P($G(BPDAT),"-",2),BPSFNO=+$G(BPDAT)

 I BPSFNM]"",BPSFNO S (BPSIX,BPSIXALT)=0,BPSFX=BPSFNO_U_BPSFNM

 E  Q 0

 S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,""))

 S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,""))

 ;

 ;-if NAME and NUMBER point to the same IEN (but not 0)

 I BPNAMIX,BPNUMIX=BPNAMIX Q BPNAMIX

 ;

 ;-else might be in another node of the "D" x-ref

 I BPNAMIX,BPNUMIX F  D  Q:BPSIX  Q:'BPNAMIX

 . S BPNAMIX=$O(^BPSF(9002313.91,"D",BPSFNM,BPNAMIX))

 . I BPNUMIX=BPNAMIX S BPSIX=BPNAMIX

 ;

 ;-If not found, try "B" x-ref value

 I 'BPSIX,BPNUMIX D

 . I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX Q

 . I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX Q

 . ;

 . ;-try additional "B" x-ref's for this NUMBER

 . F  D  Q:BPSIX  Q:'BPNUMIX

 .. S BPNUMIX=$O(^BPSF(9002313.91,"B",BPSFNO,BPNUMIX))

 .. I BPNUMIX D

 ... I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX

 ... I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX

 ;

 ;-Last resort - go through all iens'

 I 'BPSIX S BPNUMIX=0 F  D  Q:BPSIX  Q:'BPNUMIX

 . S BPNUMIX=$O(^BPSF(9002313.91,BPNUMIX))

 . I BPNUMIX,+$G(^BPSF(9002313.91,BPNUMIX,0))[BPSFNO D

 .. S BPSFNOCK=+$G(^BPSF(9002313.91,BPNUMIX,0))

 .. ; Note: Special coding included for BPSFNO of 498 (498.nn)

 .. I BPSFNOCK'=BPSFNO,$P(BPSFNOCK,".")'=498 Q

 .. I $P($G(^BPSF(9002313.91,BPNUMIX,5)),U)=BPSFNM S BPSIX=BPNUMIX

 .. I 'BPSIXALT,$P($G(^BPSF(9002313.91,BPNUMIX,0)),U,1,2)=BPSFX S BPSIXALT=BPNUMIX

 ;

 Q BPSIX

 ;

INITZPRS(ZPRS) ;BPSEGID^FLN^FLNSC^FLNPN

 S ZPRS(0)="100^9002313.9205^9002313.92051^9002313.92052"

 S ZPRS(1)="110^9002313.9206^9002313.92061^9002313.92062"

 S ZPRS(2)="140^9002313.9209^9002313.92091^9002313.92092"

 S ZPRS(3)="150^9002313.921^9002313.9211^9002313.9212"

 S ZPRS(4)="120^9002313.9207^9002313.92071^9002313.92072"

 S ZPRS(5)="160^9002313.9213^9002313.92131^9002313.92132"

 S ZPRS(6)="170^9002313.9214^9002313.92141^9002313.92142"

 S ZPRS(7)="130^9002313.9208^9002313.92081^9002313.92082"

 S ZPRS(8)="180^9002313.9215^9002313.92151^9002313.92152"

 S ZPRS(9)="200^9002313.9217^9002313.92171^9002313.92172"

 S ZPRS(10)="210^9002313.9218^9002313.92181^9002313.92182"

 S ZPRS(11)="190^9002313.9216^9002313.92161^9002313.92162"

 S ZPRS(12)="220^9002313.9219^9002313.92191^9002313.92192"

 S ZPRS(13)="230^9002313.922^9002313.9221^9002313.9222"

 Q