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