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