BHLQU.m

BHLQU ; cmi/sitka/maw - BHL Query Utilities ;  

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

 ;

 ;

 ;this routine will contain a number of utilities to support queries

 ;

PTLK ;EP - patient lookup for queries

 Q:BHLWHO=""

 S BHLPHR=+$E($P(BHLWHO,U),7,12)

 Q:BHLPHR=""

 S BHLDOB=$$HDATE^INHUT($P($G(BHLWHOM),RS,2))

 S BHLSSN=$P($G(BHLWHOM),RS)

 S BHLLNM=$P($G(BHLWHO),CS,2)

 S BHLFNM=$P($G(BHLWHO),CS,3)

 S BHLASU=$E($P(BHLWHO,U),1,6)

 I BHLASU="" D DOB

 I BHLASU=""&('$O(BHLPAT(0))) D SSN  Q

 Q:$O(BHLPAT(0))

 S BHLLOC=$O(^AUTTLOC("C",BHLASU,0))

 Q:BHLLOC=""

 S BHLDUZ=BHLLOC

 S BHLXDA=0 F  S BHLXDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA)) Q:'BHLXDA!($G(BHLPAT))  D

 . S BHLYDA=0 F  S BHLYDA=$O(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA)) Q:'BHLYDA!($G(BHLPAT))  I BHLYDA=BHLDUZ S BHLPAT=BHLXDA

 I BHLPAT="" D DOB

 I BHLPAT="" D SSN Q

 I $P(^DPT(BHLPAT,0),U,3)'=BHLDOB S BHLERCD="NODOBM",BHLPAT="" X BHLERR Q

 I BHLSSN'="" D  Q:$G(BHLERR("FATAL"))

 . I $P(^DPT(BHLPAT,0),U,9)'=BHLSSN S BHLERCD="NOSSNM",BHLPAT="" X BHLERR Q

 Q

 ;

DOB ;-- lookup the query by dob

 S BHLDCNT=0

 Q:BHLDOB=""

 S BHLDDA=0 F  S BHLDDA=$O(^DPT("ADOB",BHLDOB,BHLDDA)) Q:'BHLDDA  D

 . S BHLDCNT=BHLDCNT+1

 . S BHLPAT(BHLDCNT)=BHLDDA

 Q

 ;

SSN ;-- lookup the query by ssn

 S BHLSCNT=0

 Q:BHLSSN=""

 S BHLDDA=0 F  S BHLDDA=$O(^DPT("SSN",BHLSSN,BHLDDA)) Q:'BHLDDA  D

 . S BHLSCNT=BHLSCNT+1

 . S BHLPAT(BHLSCNT)=BHLDDA

 Q

 ;

BHLQU     ; cmi/sitka/maw - BHL Query Utilities ;  

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

 +2       ;

 +3       ;

 +4       ;this routine will contain a number of utilities to support queries

 +5       ;

PTLK      ;EP - patient lookup for queries

 +1        IF BHLWHO=""

               QUIT 

 +2        SET BHLPHR=+$EXTRACT($PIECE(BHLWHO,U),7,12)

 +3        IF BHLPHR=""

               QUIT 

 +4        SET BHLDOB=$$HDATE^INHUT($PIECE($GET(BHLWHOM),RS,2))

 +5        SET BHLSSN=$PIECE($GET(BHLWHOM),RS)

 +6        SET BHLLNM=$PIECE($GET(BHLWHO),CS,2)

 +7        SET BHLFNM=$PIECE($GET(BHLWHO),CS,3)

 +8        SET BHLASU=$EXTRACT($PIECE(BHLWHO,U),1,6)

 +9        IF BHLASU=""

               DO DOB

 +10       IF BHLASU=""&('$ORDER(BHLPAT(0)))

               DO SSN

               QUIT 

 +11       IF $ORDER(BHLPAT(0))

               QUIT 

 +12       SET BHLLOC=$ORDER(^AUTTLOC("C",BHLASU,0))

 +13       IF BHLLOC=""

               QUIT 

 +14       SET BHLDUZ=BHLLOC

 +15       SET BHLXDA=0

           FOR 

               SET BHLXDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA))

               IF 'BHLXDA!($GET(BHLPAT))

                   QUIT 

               Begin DoDot:1

 +16               SET BHLYDA=0

                   FOR 

                       SET BHLYDA=$ORDER(^AUPNPAT("D",BHLPHR,BHLXDA,BHLYDA))

                       IF 'BHLYDA!($GET(BHLPAT))

                           QUIT 

                       IF BHLYDA=BHLDUZ

                           SET BHLPAT=BHLXDA

               End DoDot:1

 +17       IF BHLPAT=""

               DO DOB

 +18       IF BHLPAT=""

               DO SSN

               QUIT 

 +19       IF $PIECE(^DPT(BHLPAT,0),U,3)'=BHLDOB

               SET BHLERCD="NODOBM"

               SET BHLPAT=""

               XECUTE BHLERR

               QUIT 

 +20       IF BHLSSN'=""

               Begin DoDot:1

 +21               IF $PIECE(^DPT(BHLPAT,0),U,9)'=BHLSSN

                       SET BHLERCD="NOSSNM"

                       SET BHLPAT=""

                       XECUTE BHLERR

                       QUIT 

               End DoDot:1

               IF $GET(BHLERR("FATAL"))

                   QUIT 

 +22       QUIT 

 +23      ;

DOB       ;-- lookup the query by dob

 +1        SET BHLDCNT=0

 +2        IF BHLDOB=""

               QUIT 

 +3        SET BHLDDA=0

           FOR 

               SET BHLDDA=$ORDER(^DPT("ADOB",BHLDOB,BHLDDA))

               IF 'BHLDDA

                   QUIT 

               Begin DoDot:1

 +4                SET BHLDCNT=BHLDCNT+1

 +5                SET BHLPAT(BHLDCNT)=BHLDDA

               End DoDot:1

 +6        QUIT 

 +7       ;

SSN       ;-- lookup the query by ssn

 +1        SET BHLSCNT=0

 +2        IF BHLSSN=""

               QUIT 

 +3        SET BHLDDA=0

           FOR 

               SET BHLDDA=$ORDER(^DPT("SSN",BHLSSN,BHLDDA))

               IF 'BHLDDA

                   QUIT 

               Begin DoDot:1

 +4                SET BHLSCNT=BHLSCNT+1

 +5                SET BHLPAT(BHLSCNT)=BHLDDA

               End DoDot:1

 +6        QUIT 

 +7       ;