- 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 Jan 18, 2025@02:52:22 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