BPSJZRP ;BHAM ISC/LJF - HL7 Registration ZRP Message ;3/5/08 10:41
;;1.0;E CLAIMS MGMT ENGINE;**1,2,7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
EN(HL,PHIX,ZRP,NPI,NCP) ;
; ZRP array contains pharmacy registration info
N ZRPS,FS,CPS,REP,NDZRO,NDHRS,NDREM,NDREP,NDREP1,NDADD,STATE
N VAIX1,VAIX2,VAIXLP,VATLE,CNF,MSGCNT,TCH
;
; Quit if no Pharmacy index provided
I '$G(PHIX) Q
;
K ZRP S ZRPS=""
;
; Set HL7 Delimiters - use standard defaults if none provided
S FS=$G(HL("FS")) I FS="" S FS="|"
S CPS=$E($G(HL("ECH"))) I CPS="" S CPS="^"
S REP=$E($G(HL("ECH")),2) I REP="" S REP="~"
;
S NDZRO=$G(^BPS(9002313.56,PHIX,0))
S NDREM=$G(^BPS(9002313.56,PHIX,"REMIT"))
S NDREP=$G(^BPS(9002313.56,PHIX,"REP"))
S NDREP1=$G(^BPS(9002313.56,PHIX,"REP1"))
S NDADD=$G(^BPS(9002313.56,PHIX,"ADDR"))
;
F ZRP=1:1:17 S ZRP(ZRP)="" ;Initialize
S (ZRP(2),NCP)=$P(NDZRO,U,2) ;NCPDP #
S ZRP(3)=$P(NDZRO,U) ;NAME
S ZRP(4)=$P(NDZRO,U,3) ;DEFAULT DEA #
;
I $L($P(NDADD,U,8)) S $P(ZRPS,CPS,1)=$P(NDADD,U,8) ;SITE ADDRESS NAME
I $L($P(NDADD,U,1)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDADD,U,1) ;SITE ADDRESS 1
I $L($P(NDADD,U,2)) S $P(ZRPS,CPS,2)=$P(NDADD,U,2) ;SITE ADDRESS 2
I $L($P(NDADD,U,3)) S $P(ZRPS,CPS,3)=$P(NDADD,U,3) ;CITY
I $L($P(NDADD,U,4)) S STATE=$P(NDADD,U,4) I STATE D ; State
. S STATE=$P($G(^DIC(5,STATE,0)),U,2)
. I STATE]"" S $P(ZRPS,CPS,4)=STATE
I $L($P(NDADD,U,5)) S $P(ZRPS,CPS,5)=$P(NDADD,U,5) ;ZIP
I ZRPS]"" S ZRP(6)=ZRPS,ZRPS=""
;
I $L($P(NDREM,U,1)) S $P(ZRPS,CPS,1)=$P(NDREM,U,1) ;REMITTANCE ADDRESS NAME
I $L($P(NDREM,U,2)) S $P(ZRPS,CPS,1)=$P(ZRPS,CPS,1)_" "_$P(NDREM,U,2) ;REMIT ADDRESS LINE 1
I $L($P(NDREM,U,3)) S $P(ZRPS,CPS,2)=$P(NDREM,U,3) ;REMIT ADDRESS LINE 2
I $L($P(NDREM,U,6)) S $P(ZRPS,CPS,3)=$P(NDREM,U,6) ;CITY
I $L($P(NDREM,U,7)) S STATE=$P(NDREM,U,7) I STATE D ;State
. S STATE=$P($G(^DIC(5,STATE,0)),U,2)
. I STATE]"" S $P(ZRPS,CPS,4)=STATE
I $L($P(NDREM,U,8)) S $P(ZRPS,CPS,5)=$P(NDREM,U,8) ;ZIP
I ZRPS]"" S ZRP(7)=ZRPS,ZRPS=""
;
; Load the Name and Means Fields
S VAIX1=$P(NDREP,U,3)
S VAIX2=$P(NDREP,U,4)
S VAIXLP=$P(NDREP,U,5)
;
; Contact
I $G(VAIX1) S VATLE="" D
. S CNF=$$VA200NM^BPSJUTL(VAIX1,.VATLE,.HL) I CNF]"" S ZRP(8)=CNF
. I VATLE]"" S ZRP(9)=VATLE
. S CNF=$$VA20013^BPSJUTL(VAIX1,.HL) I CNF]"" S ZRP(10)=CNF
;
; Alternate Contact
I $G(VAIX2) S VATLE="" D
. S CNF=$$VA200NM^BPSJUTL(VAIX2,.VATLE,.HL) I CNF]"" S ZRP(11)=CNF
. I VATLE]"" S ZRP(12)=VATLE
. S CNF=$$VA20013^BPSJUTL(VAIX2,.HL) I CNF]"" S ZRP(13)=CNF
;
; Lead Pharmacist
I $G(VAIXLP) S VATLE="" D
. S CNF=$$VA200NM^BPSJUTL(VAIXLP,.VATLE,.HL) I CNF]"" S ZRP(14)=CNF
. I VATLE]"" S ZRP(15)=VATLE
;
; Pharmacist's License
I $L($P(NDREP1,U)) S ZRP(16)=$P(NDREP1,U)
;
; NPI
S ZRP(17)=$G(NPI)
;
; Encode special chars. Add Field separators.
S TCH("\")="\E\",TCH("&")="\T\",TCH("|")="\F\"
S (ZRPS(5),ZRPS(10),ZRPS(13))=1 ;Fields with HL7 repetion chars
F ZRP=17:-1:1 D S ZRP(ZRP)=$$ENCODE^BPSJUTL(ZRP(ZRP),.TCH)_FS
. I $G(ZRPS(ZRP)) K TCH("~") ; don't convert repetion chars
. E S TCH("~")="\R\" ; ok to convert repetion chars
S ZRP="ZRP|"
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJZRP 3298 printed Oct 16, 2024@17:52 Page 2
BPSJZRP ;BHAM ISC/LJF - HL7 Registration ZRP Message ;3/5/08 10:41
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,2,7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
EN(HL,PHIX,ZRP,NPI,NCP) ;
+1 ; ZRP array contains pharmacy registration info
+2 NEW ZRPS,FS,CPS,REP,NDZRO,NDHRS,NDREM,NDREP,NDREP1,NDADD,STATE
+3 NEW VAIX1,VAIX2,VAIXLP,VATLE,CNF,MSGCNT,TCH
+4 ;
+5 ; Quit if no Pharmacy index provided
+6 IF '$GET(PHIX)
QUIT
+7 ;
+8 KILL ZRP
SET ZRPS=""
+9 ;
+10 ; Set HL7 Delimiters - use standard defaults if none provided
+11 SET FS=$GET(HL("FS"))
IF FS=""
SET FS="|"
+12 SET CPS=$EXTRACT($GET(HL("ECH")))
IF CPS=""
SET CPS="^"
+13 SET REP=$EXTRACT($GET(HL("ECH")),2)
IF REP=""
SET REP="~"
+14 ;
+15 SET NDZRO=$GET(^BPS(9002313.56,PHIX,0))
+16 SET NDREM=$GET(^BPS(9002313.56,PHIX,"REMIT"))
+17 SET NDREP=$GET(^BPS(9002313.56,PHIX,"REP"))
+18 SET NDREP1=$GET(^BPS(9002313.56,PHIX,"REP1"))
+19 SET NDADD=$GET(^BPS(9002313.56,PHIX,"ADDR"))
+20 ;
+21 ;Initialize
FOR ZRP=1:1:17
SET ZRP(ZRP)=""
+22 ;NCPDP #
SET (ZRP(2),NCP)=$PIECE(NDZRO,U,2)
+23 ;NAME
SET ZRP(3)=$PIECE(NDZRO,U)
+24 ;DEFAULT DEA #
SET ZRP(4)=$PIECE(NDZRO,U,3)
+25 ;
+26 ;SITE ADDRESS NAME
IF $LENGTH($PIECE(NDADD,U,8))
SET $PIECE(ZRPS,CPS,1)=$PIECE(NDADD,U,8)
+27 ;SITE ADDRESS 1
IF $LENGTH($PIECE(NDADD,U,1))
SET $PIECE(ZRPS,CPS,1)=$PIECE(ZRPS,CPS,1)_" "_$PIECE(NDADD,U,1)
+28 ;SITE ADDRESS 2
IF $LENGTH($PIECE(NDADD,U,2))
SET $PIECE(ZRPS,CPS,2)=$PIECE(NDADD,U,2)
+29 ;CITY
IF $LENGTH($PIECE(NDADD,U,3))
SET $PIECE(ZRPS,CPS,3)=$PIECE(NDADD,U,3)
+30 ; State
IF $LENGTH($PIECE(NDADD,U,4))
SET STATE=$PIECE(NDADD,U,4)
IF STATE
Begin DoDot:1
+31 SET STATE=$PIECE($GET(^DIC(5,STATE,0)),U,2)
+32 IF STATE]""
SET $PIECE(ZRPS,CPS,4)=STATE
End DoDot:1
+33 ;ZIP
IF $LENGTH($PIECE(NDADD,U,5))
SET $PIECE(ZRPS,CPS,5)=$PIECE(NDADD,U,5)
+34 IF ZRPS]""
SET ZRP(6)=ZRPS
SET ZRPS=""
+35 ;
+36 ;REMITTANCE ADDRESS NAME
IF $LENGTH($PIECE(NDREM,U,1))
SET $PIECE(ZRPS,CPS,1)=$PIECE(NDREM,U,1)
+37 ;REMIT ADDRESS LINE 1
IF $LENGTH($PIECE(NDREM,U,2))
SET $PIECE(ZRPS,CPS,1)=$PIECE(ZRPS,CPS,1)_" "_$PIECE(NDREM,U,2)
+38 ;REMIT ADDRESS LINE 2
IF $LENGTH($PIECE(NDREM,U,3))
SET $PIECE(ZRPS,CPS,2)=$PIECE(NDREM,U,3)
+39 ;CITY
IF $LENGTH($PIECE(NDREM,U,6))
SET $PIECE(ZRPS,CPS,3)=$PIECE(NDREM,U,6)
+40 ;State
IF $LENGTH($PIECE(NDREM,U,7))
SET STATE=$PIECE(NDREM,U,7)
IF STATE
Begin DoDot:1
+41 SET STATE=$PIECE($GET(^DIC(5,STATE,0)),U,2)
+42 IF STATE]""
SET $PIECE(ZRPS,CPS,4)=STATE
End DoDot:1
+43 ;ZIP
IF $LENGTH($PIECE(NDREM,U,8))
SET $PIECE(ZRPS,CPS,5)=$PIECE(NDREM,U,8)
+44 IF ZRPS]""
SET ZRP(7)=ZRPS
SET ZRPS=""
+45 ;
+46 ; Load the Name and Means Fields
+47 SET VAIX1=$PIECE(NDREP,U,3)
+48 SET VAIX2=$PIECE(NDREP,U,4)
+49 SET VAIXLP=$PIECE(NDREP,U,5)
+50 ;
+51 ; Contact
+52 IF $GET(VAIX1)
SET VATLE=""
Begin DoDot:1
+53 SET CNF=$$VA200NM^BPSJUTL(VAIX1,.VATLE,.HL)
IF CNF]""
SET ZRP(8)=CNF
+54 IF VATLE]""
SET ZRP(9)=VATLE
+55 SET CNF=$$VA20013^BPSJUTL(VAIX1,.HL)
IF CNF]""
SET ZRP(10)=CNF
End DoDot:1
+56 ;
+57 ; Alternate Contact
+58 IF $GET(VAIX2)
SET VATLE=""
Begin DoDot:1
+59 SET CNF=$$VA200NM^BPSJUTL(VAIX2,.VATLE,.HL)
IF CNF]""
SET ZRP(11)=CNF
+60 IF VATLE]""
SET ZRP(12)=VATLE
+61 SET CNF=$$VA20013^BPSJUTL(VAIX2,.HL)
IF CNF]""
SET ZRP(13)=CNF
End DoDot:1
+62 ;
+63 ; Lead Pharmacist
+64 IF $GET(VAIXLP)
SET VATLE=""
Begin DoDot:1
+65 SET CNF=$$VA200NM^BPSJUTL(VAIXLP,.VATLE,.HL)
IF CNF]""
SET ZRP(14)=CNF
+66 IF VATLE]""
SET ZRP(15)=VATLE
End DoDot:1
+67 ;
+68 ; Pharmacist's License
+69 IF $LENGTH($PIECE(NDREP1,U))
SET ZRP(16)=$PIECE(NDREP1,U)
+70 ;
+71 ; NPI
+72 SET ZRP(17)=$GET(NPI)
+73 ;
+74 ; Encode special chars. Add Field separators.
+75 SET TCH("\")="\E\"
SET TCH("&")="\T\"
SET TCH("|")="\F\"
+76 ;Fields with HL7 repetion chars
SET (ZRPS(5),ZRPS(10),ZRPS(13))=1
+77 FOR ZRP=17:-1:1
Begin DoDot:1
+78 ; don't convert repetion chars
IF $GET(ZRPS(ZRP))
KILL TCH("~")
+79 ; ok to convert repetion chars
IF '$TEST
SET TCH("~")="\R\"
End DoDot:1
SET ZRP(ZRP)=$$ENCODE^BPSJUTL(ZRP(ZRP),.TCH)_FS
+80 SET ZRP="ZRP|"
+81 ;
+82 QUIT
+83 ;
