- 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 ;
