BHLPID.m

BHLPID ; cmi/flag/maw - BHL IHS PID Supplement ; [ 06/10/2002  6:51 AM ]

 ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 ;

 ;this routine will contain code to supplement particular fields in the

 ;IHS PID segment

 ;

PID3 ;-- this will generate the IHS PID-3 field

 S BHLRN=$$LZERO($$HRN^AUPNPAT(INDA,DUZ(2)),6)

 S BHLASU=$$VAL^XBDIQ1(9999999.06,DUZ(2),.12)

 S BHLLOC=$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)

 S INA("PID3",1)=BHLASU_BHLRN  ;_CS_CS_CS_CS_BHLLOC_".DOMAIN.NAME"_CS_"DNS" 

 S BHL("SSN")=$$VAL^XBDIQ1(2,INDA,.09)

 ;

PID4 ;-- this will generate the IHS PID-4 field

 S BHLCNT=0

 S BHLDA=0 F  S BHLDA=$O(^AUPNPAT(INDA,41,BHLDA)) Q:'BHLDA  D

 . Q:BHLDA=DUZ(2)

 . S BHLRN=$$LZERO($$HRN^AUPNPAT(INDA,BHLDA),6)

 . S BHLASU=$$VAL^XBDIQ1(9999999.06,BHLDA,.12)

 . S BHLLOC=$$VAL^XBDIQ1(9999999.06,BHLDA,.01)

 . S BHLCNT=BHLCNT+1

 . S $P(INA("PID4",1),RS,BHLCNT)=BHLASU_BHLRN  ;_CS_CS_CS_CS_BHLLOC_".DOMAIN.NAME"_CS_"DNS"  ;left in for backward compatability version 2.3.1 or earlier

 S INA("PID3",1)=INA("PID3",1)_$S($G(INA("PID4",1)):RS,1:"")_$G(INA("PID4",1))_$S($G(BHL("SSN")):RS,1:"")_$G(BHL("SSN"))  ;version 2.4 of the standard has all identifiers in PID3

 S INA("PID3")=INA("PID3",1)  ;_$S($G(INA("PID4",1)):RS,1:"")_$G(INA("PID4",1))_$S($G(BHL("SSN")):RS,1:"")_$G(BHL("SSN"))  ;version 2.4 of the standard has all identifiers in PID3

 Q

 ;

LZERO(V,L) ;EP - left zero fill

 NEW %,I

 S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V

 Q V

 ;

QRY ;EP - setup the V02 PID segment

 S BHLCNT=0

 S INDA=$G(BHLPAT(1))

 S BHLDA=1 F  S BHLDA=$O(BHLPAT(BHLDA)) Q:'BHLDA  D

 . S BHLCNT=BHLCNT+1

 . S INDA(2,BHLCNT)=$G(BHLPAT(BHLDA))

 Q

 ;

BHLPID    ; cmi/flag/maw - BHL IHS PID Supplement ; [ 06/10/2002  6:51 AM ]

 +1       ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001

 +2       ;

 +3       ;this routine will contain code to supplement particular fields in the

 +4       ;IHS PID segment

 +5       ;

PID3      ;-- this will generate the IHS PID-3 field

 +1        SET BHLRN=$$LZERO($$HRN^AUPNPAT(INDA,DUZ(2)),6)

 +2        SET BHLASU=$$VAL^XBDIQ1(9999999.06,DUZ(2),.12)

 +3        SET BHLLOC=$$VAL^XBDIQ1(9999999.06,DUZ(2),.01)

 +4       ;_CS_CS_CS_CS_BHLLOC_".DOMAIN.NAME"_CS_"DNS" 

           SET INA("PID3",1)=BHLASU_BHLRN

 +5        SET BHL("SSN")=$$VAL^XBDIQ1(2,INDA,.09)

 +6       ;

PID4      ;-- this will generate the IHS PID-4 field

 +1        SET BHLCNT=0

 +2        SET BHLDA=0

           FOR 

               SET BHLDA=$ORDER(^AUPNPAT(INDA,41,BHLDA))

               IF 'BHLDA

                   QUIT 

               Begin DoDot:1

 +3                IF BHLDA=DUZ(2)

                       QUIT 

 +4                SET BHLRN=$$LZERO($$HRN^AUPNPAT(INDA,BHLDA),6)

 +5                SET BHLASU=$$VAL^XBDIQ1(9999999.06,BHLDA,.12)

 +6                SET BHLLOC=$$VAL^XBDIQ1(9999999.06,BHLDA,.01)

 +7                SET BHLCNT=BHLCNT+1

 +8       ;_CS_CS_CS_CS_BHLLOC_".DOMAIN.NAME"_CS_"DNS"  ;left in for backward compatability version 2.3.1 or earlier

                   SET $PIECE(INA("PID4",1),RS,BHLCNT)=BHLASU_BHLRN

               End DoDot:1

 +9       ;version 2.4 of the standard has all identifiers in PID3

           SET INA("PID3",1)=INA("PID3",1)_$SELECT($GET(INA("PID4",1)):RS,1:"")_$GET(INA("PID4",1))_$SELECT($GET(BHL("SSN")):RS,1:"")_$GET(BHL("SSN"))

 +10      ;_$S($G(INA("PID4",1)):RS,1:"")_$G(INA("PID4",1))_$S($G(BHL("SSN")):RS,1:"")_$G(BHL("SSN"))  ;version 2.4 of the standard has all identifiers in PID3

           SET INA("PID3")=INA("PID3",1)

 +11       QUIT 

 +12      ;

LZERO(V,L) ;EP - left zero fill

 +1        NEW %,I

 +2        SET %=$LENGTH(V)

           SET Z=L-%

           FOR I=1:1:Z

               SET V="0"_V

 +3        QUIT V

 +4       ;

QRY       ;EP - setup the V02 PID segment

 +1        SET BHLCNT=0

 +2        SET INDA=$GET(BHLPAT(1))

 +3        SET BHLDA=1

           FOR 

               SET BHLDA=$ORDER(BHLPAT(BHLDA))

               IF 'BHLDA

                   QUIT 

               Begin DoDot:1

 +4                SET BHLCNT=BHLCNT+1

 +5                SET INDA(2,BHLCNT)=$GET(BHLPAT(BHLDA))

               End DoDot:1

 +6        QUIT 

 +7       ;