BLRAG04 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
;
; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
;
; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
;
; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest\
; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
;
PTLK(BDGY,BDGP,BDGC,BDGGIEN,BDGADM) ;EP Patient Lookup
;
; RPC: BLR PATIENT LOOKUP
;INPUT
; BDGP = (required) Partail patient name; Could also be DOB, SSN, or chart #.
; BDGC = (optional) Max number of patients returned; defaults to 10
; BDGGIEN = (optional) Specific IEN of patient
; BDGADM = (optional) flag to only return patients that are currently
; admitted; 0=all patients; 1=admitted patients only
;RETURNS:
; (0) NAME
; (1) HRN
; (2) SSN
; (3) DOB
; (4) IEN
; (5) STATUS
; (6) GENDER
; (7) ADMISSION_IEN
; (8) INPATIENT_STATUS
; (9) WARD
; (10) ROOM_BED
; (11) TREATING_SPEC
; (12) PRIM_PHYS
; (13) ATT_PHYS
; (14) ADMITTING_PROVIDER
; (15) LAST_EDITED_BY
; (16) LAST_EDITED_DATE
; (17) DISCHARGE_IEN
; (18) DISCHARGE_TYPE
; (19) DATE_OF_DEATH
; (20) CITY
; (21) STATE
;
;Find up to BDGC patients matching BDGP*
;Supports DOB Lookup, SSN Lookup
;
;BDGADM - if passed, only return patients that are currently admitted.
;
N BDGXI
S BDGP=$G(BDGP,"")
S:$G(BDGC)="" BDGC=10
S BDGY=$NA(^TMP("BLRAG",$J)) K @BDGY
S BDGXI=0
N BDGHRN,BDGZ,BDGDLIM,BDGRET,BDGDPT,BDGRET,BDGIEN,BDGFILE
N BDGIENS,BDGFIELDS,BDGFLAGS,BDGVALUE,BDGNUMBER,BDGINDEXES,BDGSCREEN
N BDGTARG,BDGMSG,BDGRSLT,BDGCNT
S BDGDLIM="^"
S @BDGY@(0)="ERROR_ID"
I '+$G(DUZ) Q
I '$D(DUZ(2)) Q
; 0 1 2 3 4 5 6 7 8 9 10 11 12
S @BDGY@(BDGXI)="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030STATUS^T00010GENDER^I00020ADMISSION_IEN^T00030INPATIENT_STATUS^T00030WARD^T00030ROOM_BED^I00020TREATING_SPEC^I00020PRIM_PHYS^"
; 13 14 15 16 17 18 19
S @BDGY@(BDGXI)=@BDGY@(BDGXI)_"I00020ATT_PHYS^T00030ADMITTING_PROVIDER^I00020LAST_EDITED_BY^D00020LAST_EDITED_DATE^I00030DISCHARGE_IEN^T00030DISCHARGE_TYPE^D00020DATE_OF_DEATH"
; 20 21
S @BDGY@(BDGXI)=@BDGY@(BDGXI)_"T00020CITY^T00020STATE"
S BDGXI=BDGXI+1
I $G(BDGGIEN) D DATA(.BDGY,BDGGIEN,BDGXI) Q
;
DOB ;DOB Lookup
I +DUZ(2),((BDGP?1.2N1"/"1.2N1"/"1.4N)!(BDGP?1.2N1" "1.2N1" "1.4N)!(BDGP?1.2N1"-"1.2N1"-"1.4N)!(BDGP?1.2N1"."1.2N1"."1.4N)) D Q
. S X=BDGP S %DT="P" D ^%DT S BDGP=Y Q:'+Y
. Q:'$D(^DPT("ADOB",BDGP))
. S BDGIEN=0 F S BDGIEN=$O(^DPT("ADOB",BDGP,BDGIEN)) Q:'+BDGIEN D
. . Q:'$D(^DPT(BDGIEN,0))
. . I $G(BDGADM) Q:'$$STATUS(BDGIEN,1)
. . D DATA(.BDGY,BDGIEN,.BDGXI)
. . Q
. Q
;
;Chart# Lookup
I +DUZ(2),BDGP]"",$D(^AUPNPAT("D",BDGP)) D Q
. S BDGIEN=0 F S BDGIEN=$O(^AUPNPAT("D",BDGP,BDGIEN)) Q:'+BDGIEN I $D(^AUPNPAT("D",BDGP,BDGIEN,DUZ(2))) D Q
. . Q:'$D(^DPT(BDGIEN,0))
. . I $G(BDGADM) Q:'$$STATUS(BDGIEN,1)
. . D DATA(.BDGY,BDGIEN,.BDGXI)
. . Q
. Q
;
;SSN Lookup
I (BDGP?9N)!(BDGP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BDGP)) D Q
. Q
. S BDGIEN=0 F S BDGIEN=$O(^DPT("SSN",BDGP,BDGIEN)) Q:'+BDGIEN D Q
. . Q:'$D(^DPT(BDGIEN,0))
. . I $G(BDGADM) Q:'$$STATUS(BDGIEN,1)
. . D DATA(.BDGY,BDGIEN,.BDGXI)
. . Q
. Q
;
;All Patients
I BDGP="" D Q
. D LISTALL^BEHOPTPL(.PLIST,"",1)
. S BDGCNT=0 F S BDGCNT=$O(PLIST(BDGCNT)) Q:'BDGCNT!(BDGCNT>$G(BDGC)) D
. . I $G(BDGADM) Q:'$$STATUS($P(PLIST(BDGCNT),U,1),1)
. . D DATA(.BDGY,$P(PLIST(BDGCNT),U,1),.BDGXI)
. . Q
. Q
;
S BDGFILE=2
S BDGIENS=""
S BDGFIELDS=".01"
S BDGFLAGS=""
S BDGVALUE=BDGP
S BDGNUMBER=BDGC
S BDGINDEXES="B"
S BDGSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
S BDGIDEN=""
S BDGTARG="BDGRSLT"
S BDGMSG=""
D FIND^DIC(BDGFILE,BDGIENS,BDGFIELDS,BDGFLAGS,BDGVALUE,BDGNUMBER,BDGINDEXES,BDGSCREEN,BDGIDEN,BDGTARG,BDGMSG)
I '+$G(BDGRSLT("DILIST",0)) Q
N BDGCNT S BDGCNT=2
F BDGX=1:1:$P(BDGRSLT("DILIST",0),U) D
. S BDGIEN=BDGRSLT("DILIST",2,BDGX)
. I $G(BDGADM) Q:'$$STATUS(BDGIEN,1)
. D DATA(.BDGY,BDGIEN,.BDGXI)
. Q
Q
;
DATA(BDGY,BDGIEN,BDGXI) ;
S BDGDPT=$G(^DPT(BDGIEN,0))
S BDGZ=$P(BDGDPT,U)
S BDGHRN=$P($G(^AUPNPAT(BDGIEN,41,DUZ(2),0)),U,2) ;CHART
I BDGHRN="" Q ;NO CHART AT THIS DUZ2
I $P($G(^AUPNPAT(BDGIEN,41,DUZ(2),0)),U,3) S BDGHRN=BDGHRN_"(*)" Q ;HMW 20050721 Record Inactivated
S $P(BDGZ,BDGDLIM,2)=BDGHRN
S $P(BDGZ,BDGDLIM,3)=$P(BDGDPT,U,9) ;SSN
S Y=$P(BDGDPT,U,3) X ^DD("DD")
S $P(BDGZ,BDGDLIM,4)=Y ;DOB
S $P(BDGZ,BDGDLIM,5)=BDGIEN
S $P(BDGZ,BDGDLIM,6)=$$STATUS(BDGIEN)
S $P(BDGZ,BDGDLIM,7)=$$SEX^AUPNPAT(BDGIEN)_"^"_$$INP(BDGIEN)
S $P(BDGZ,BDGDLIM,21)=$$GET1^DIQ(2,BDGIEN_",",.114) ;get city
S $P(BDGZ,BDGDLIM,22)=$$GET1^DIQ(2,BDGIEN_",",.115) ;get state
S DFN=BDGIEN I $G(DFN) S $P(BDGZ,BDGDLIM,20)=$$DOD^AUPNPAT(DFN) ; Date of Death
S @BDGY@(BDGXI)=BDGZ,BDGXI=BDGXI+1
Q
STATUS(DFN,CHECK) ;
N STATUS,A,INP
I 'DFN Q ""
K VAIN
I $G(CHECK) D Q INP
.D IN5^VADPT
.I $G(VAIP(1)) S INP=1 Q
.S INP=0
D INP^DGPMV10,Q^VADPT3
S A=$S("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
S STATUS=$S('A:"IN",1:"")_"ACTIVE "_$S("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",$P(DGPMVI(8),"^",2)["OBSERVATION":"OBSERVATION PATIENT",1:"INPATIENT")
Q STATUS
INP(DFN) ;
N BDGINP,BDGWARD,BDGRMBD,BDGIEN,BDGTRSP,BDGPPHYS,BDGAPHYS,BDGLEBY,BDGLEON,BDGADIS,BDGDIST,BDGADMPV
N BDGARY
K VAIN
S BDGINP=0
D INP^VADPT M BDGARY=VAIN
S BDGIEN=+$G(VAIN(1)) I BDGIEN S BDGINP=1
I 'BDGINP D INP^DGPMV10 S BDGDIEN=$G(DGPMVI(1))
I 'BDGINP S BDGIEN=$$GET1^DIQ(405,BDGDIEN,.14,"I")
S BDGLEBY=$$GET1^DIQ(405,$S(BDGINP:BDGIEN,1:BDGDIEN),102,"I")
S BDGLEON=$$GET1^DIQ(405,$S(BDGINP:BDGIEN,1:BDGDIEN),103,"I")
S BDGPPHYS=$P(BDGARY(2),U)
S BDGTRSP=$P(BDGARY(3),U)
S BDGWARD=$P(BDGARY(4),U)
S BDGRMBD=$P(BDGARY(5),U) I BDGRMBD]"" S BDGRMBD=$O(^DG(405.4,"B",BDGRMBD,0))
S BDGAPHYS=$P(BDGARY(11),U)
S BDGADIS=$$GET1^DIQ(405,BDGIEN,.17,"I")
I BDGADIS D
.S BDGDIST=$$GET1^DIQ(405,BDGADIS,.04,"E")
S BDGADMPV=$$GET1^DIQ(405,BDGIEN,9999999.02,"E")
Q BDGIEN_U_BDGINP_U_BDGWARD_U_BDGRMBD_U_BDGTRSP_U_BDGPPHYS_U_BDGAPHYS_U_BDGADMPV_U_BDGLEBY_U_BDGLEON_U_BDGADIS_U_$G(BDGDIST)
;
BLRAG04 ; IHS/MSC/SAT - LABORATORY ACCESSION GUI RPCS ;
+1 ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
+2 ;
+3 ; BLR REF LAB USING LEDI - UL^BLRAG02 = return the value of the 'REF LAB USING LEDI?' field in the BLR MASTER CONTROL file
+4 ; BLR ICD LOOKUP - ICDLKUP^BLRAG07 = ICD code lookup
+5 ; BLR ORDER REASON LKUP - ORL^BLRAG07 = return order reasons from file 100.03
+6 ; BLR PATIENT LOOKUP - PTLK^BLRAG04 = Patient Lookup
+7 ; BLR PRINTERS AVAILABLE - DEVICE^BLRAG10 = return available printers from the DEVICE file
+8 ; BLR USER LOOKUP - NP^BLRAG06 = return entries from the NEW PERSON table 200 that are 'active'
+9 ;
+10 ; BLR ACCESSION - ACC^BLRAG05 = lab accession processor
+11 ; BLR ACCESSION PRINT - ABR^BLRAG02 = reprint accession label or manifest
+12 ; BLR ALL NON-ACCESSIONED - ANA^BLRAG01 = return all non-accessioned lab records
+13 ; BLR ALL-ACCESSIONED - ABD^BLRAG02 = return all accessioned records for given date range
+14 ; BLR COLLECTION INFO - BLC^BLRAG06 = check BLR PT CONFIRM parameter and return insurances for patient
+15 ; BLR DELETE TEST - DELTST^BLRAG08 = Cancel tests - Test are no longer deleted, instead the status is changed to Not Performed.
+16 ; BLR ORDER/TEST STATUS - LROS^BLRAG03 = return order/test status for given patient and date range
+17 ;
+18 ; BLR SHIP CONF - SC^BLRAG09A = select a shipping configuration
+19 ; BLR MANIFEST BUILD - BM^BLRAG09B = build a shipping manifest
+20 ; BLR MANIFEST CLOSE/SHIP - CLSHIP^BLRAG09C = Close/ship a shipping manifest
+21 ; BLR MANIFEST DISPLAY - DISP^BLRAG09G = screen formatted text for manifest display
+22 ; BLR MANIFEST START - SMONLY^BLRAG09C = Start a shipping manifest only, no building
+23 ; BLR MANIFEST TEST ADD - ADDTEST^BLRAG09C= Add tests to an existing manifest\
+24 ; BLR MANIFEST TEST REMOVE - REMVTST^BLRAG09C= Remove a test from manifest - actually flags test as "removed".
+25 ; BLR MANIFEST TESTS TO ADD- TARPC^BLRAG09B = return tests that can be added to a manifest
+26 ;
PTLK(BDGY,BDGP,BDGC,BDGGIEN,BDGADM) ;EP Patient Lookup
+1 ;
+2 ; RPC: BLR PATIENT LOOKUP
+3 ;INPUT
+4 ; BDGP = (required) Partail patient name; Could also be DOB, SSN, or chart #.
+5 ; BDGC = (optional) Max number of patients returned; defaults to 10
+6 ; BDGGIEN = (optional) Specific IEN of patient
+7 ; BDGADM = (optional) flag to only return patients that are currently
+8 ; admitted; 0=all patients; 1=admitted patients only
+9 ;RETURNS:
+10 ; (0) NAME
+11 ; (1) HRN
+12 ; (2) SSN
+13 ; (3) DOB
+14 ; (4) IEN
+15 ; (5) STATUS
+16 ; (6) GENDER
+17 ; (7) ADMISSION_IEN
+18 ; (8) INPATIENT_STATUS
+19 ; (9) WARD
+20 ; (10) ROOM_BED
+21 ; (11) TREATING_SPEC
+22 ; (12) PRIM_PHYS
+23 ; (13) ATT_PHYS
+24 ; (14) ADMITTING_PROVIDER
+25 ; (15) LAST_EDITED_BY
+26 ; (16) LAST_EDITED_DATE
+27 ; (17) DISCHARGE_IEN
+28 ; (18) DISCHARGE_TYPE
+29 ; (19) DATE_OF_DEATH
+30 ; (20) CITY
+31 ; (21) STATE
+32 ;
+33 ;Find up to BDGC patients matching BDGP*
+34 ;Supports DOB Lookup, SSN Lookup
+35 ;
+36 ;BDGADM - if passed, only return patients that are currently admitted.
+37 ;
+38 NEW BDGXI
+39 SET BDGP=$GET(BDGP,"")
+40 IF $GET(BDGC)=""
SET BDGC=10
+41 SET BDGY=$NAME(^TMP("BLRAG",$JOB))
KILL @BDGY
+42 SET BDGXI=0
+43 NEW BDGHRN,BDGZ,BDGDLIM,BDGRET,BDGDPT,BDGRET,BDGIEN,BDGFILE
+44 NEW BDGIENS,BDGFIELDS,BDGFLAGS,BDGVALUE,BDGNUMBER,BDGINDEXES,BDGSCREEN
+45 NEW BDGTARG,BDGMSG,BDGRSLT,BDGCNT
+46 SET BDGDLIM="^"
+47 SET @BDGY@(0)="ERROR_ID"
+48 IF '+$GET(DUZ)
QUIT
+49 IF '$DATA(DUZ(2))
QUIT
+50 ; 0 1 2 3 4 5 6 7 8 9 10 11 12
+51 SET @BDGY@(BDGXI)="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN^T00030STATUS^T00010GENDER^I00020ADMISSION_IEN^T00030INPATIENT_STATUS^T00030WARD^T00030ROOM_BED^I00020TREATING_SPEC^I00020PRIM_PHYS^"
+52 ; 13 14 15 16 17 18 19
+53 SET @BDGY@(BDGXI)=@BDGY@(BDGXI)_"I00020ATT_PHYS^T00030ADMITTING_PROVIDER^I00020LAST_EDITED_BY^D00020LAST_EDITED_DATE^I00030DISCHARGE_IEN^T00030DISCHARGE_TYPE^D00020DATE_OF_DEATH"
+54 ; 20 21
+55 SET @BDGY@(BDGXI)=@BDGY@(BDGXI)_"T00020CITY^T00020STATE"
+56 SET BDGXI=BDGXI+1
+57 IF $GET(BDGGIEN)
DO DATA(.BDGY,BDGGIEN,BDGXI)
QUIT
+58 ;
DOB ;DOB Lookup
+1 IF +DUZ(2)
IF ((BDGP?1.2N1"/"1.2N1"/"1.4N)!(BDGP?1.2N1" "1.2N1" "1.4N)!(BDGP?1.2N1"-"1.2N1"-"1.4N)!(BDGP?1.2N1"."1.2N1"."1.4N))
Begin DoDot:1
+2 SET X=BDGP
SET %DT="P"
DO ^%DT
SET BDGP=Y
IF '+Y
QUIT
+3 IF '$DATA(^DPT("ADOB",BDGP))
QUIT
+4 SET BDGIEN=0
FOR
SET BDGIEN=$ORDER(^DPT("ADOB",BDGP,BDGIEN))
IF '+BDGIEN
QUIT
Begin DoDot:2
+5 IF '$DATA(^DPT(BDGIEN,0))
QUIT
+6 IF $GET(BDGADM)
IF '$$STATUS(BDGIEN,1)
QUIT
+7 DO DATA(.BDGY,BDGIEN,.BDGXI)
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 ;Chart# Lookup
+12 IF +DUZ(2)
IF BDGP]""
IF $DATA(^AUPNPAT("D",BDGP))
Begin DoDot:1
+13 SET BDGIEN=0
FOR
SET BDGIEN=$ORDER(^AUPNPAT("D",BDGP,BDGIEN))
IF '+BDGIEN
QUIT
IF $DATA(^AUPNPAT("D",BDGP,BDGIEN,DUZ(2)))
Begin DoDot:2
+14 IF '$DATA(^DPT(BDGIEN,0))
QUIT
+15 IF $GET(BDGADM)
IF '$$STATUS(BDGIEN,1)
QUIT
+16 DO DATA(.BDGY,BDGIEN,.BDGXI)
+17 QUIT
End DoDot:2
QUIT
+18 QUIT
End DoDot:1
QUIT
+19 ;
+20 ;SSN Lookup
+21 IF (BDGP?9N)!(BDGP?3N1"-"2N1"-"4N)
IF $DATA(^DPT("SSN",BDGP))
Begin DoDot:1
+22 QUIT
+23 SET BDGIEN=0
FOR
SET BDGIEN=$ORDER(^DPT("SSN",BDGP,BDGIEN))
IF '+BDGIEN
QUIT
Begin DoDot:2
+24 IF '$DATA(^DPT(BDGIEN,0))
QUIT
+25 IF $GET(BDGADM)
IF '$$STATUS(BDGIEN,1)
QUIT
+26 DO DATA(.BDGY,BDGIEN,.BDGXI)
+27 QUIT
End DoDot:2
QUIT
+28 QUIT
End DoDot:1
QUIT
+29 ;
+30 ;All Patients
+31 IF BDGP=""
Begin DoDot:1
+32 DO LISTALL^BEHOPTPL(.PLIST,"",1)
+33 SET BDGCNT=0
FOR
SET BDGCNT=$ORDER(PLIST(BDGCNT))
IF 'BDGCNT!(BDGCNT>$GET(BDGC))
QUIT
Begin DoDot:2
+34 IF $GET(BDGADM)
IF '$$STATUS($PIECE(PLIST(BDGCNT),U,1),1)
QUIT
+35 DO DATA(.BDGY,$PIECE(PLIST(BDGCNT),U,1),.BDGXI)
+36 QUIT
End DoDot:2
+37 QUIT
End DoDot:1
QUIT
+38 ;
+39 SET BDGFILE=2
+40 SET BDGIENS=""
+41 SET BDGFIELDS=".01"
+42 SET BDGFLAGS=""
+43 SET BDGVALUE=BDGP
+44 SET BDGNUMBER=BDGC
+45 SET BDGINDEXES="B"
+46 SET BDGSCREEN=$SELECT(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
+47 SET BDGIDEN=""
+48 SET BDGTARG="BDGRSLT"
+49 SET BDGMSG=""
+50 DO FIND^DIC(BDGFILE,BDGIENS,BDGFIELDS,BDGFLAGS,BDGVALUE,BDGNUMBER,BDGINDEXES,BDGSCREEN,BDGIDEN,BDGTARG,BDGMSG)
+51 IF '+$GET(BDGRSLT("DILIST",0))
QUIT
+52 NEW BDGCNT
SET BDGCNT=2
+53 FOR BDGX=1:1:$PIECE(BDGRSLT("DILIST",0),U)
Begin DoDot:1
+54 SET BDGIEN=BDGRSLT("DILIST",2,BDGX)
+55 IF $GET(BDGADM)
IF '$$STATUS(BDGIEN,1)
QUIT
+56 DO DATA(.BDGY,BDGIEN,.BDGXI)
+57 QUIT
End DoDot:1
+58 QUIT
+59 ;
DATA(BDGY,BDGIEN,BDGXI) ;
+1 SET BDGDPT=$GET(^DPT(BDGIEN,0))
+2 SET BDGZ=$PIECE(BDGDPT,U)
+3 ;CHART
SET BDGHRN=$PIECE($GET(^AUPNPAT(BDGIEN,41,DUZ(2),0)),U,2)
+4 ;NO CHART AT THIS DUZ2
IF BDGHRN=""
QUIT
+5 ;HMW 20050721 Record Inactivated
IF $PIECE($GET(^AUPNPAT(BDGIEN,41,DUZ(2),0)),U,3)
SET BDGHRN=BDGHRN_"(*)"
QUIT
+6 SET $PIECE(BDGZ,BDGDLIM,2)=BDGHRN
+7 ;SSN
SET $PIECE(BDGZ,BDGDLIM,3)=$PIECE(BDGDPT,U,9)
+8 SET Y=$PIECE(BDGDPT,U,3)
XECUTE ^DD("DD")
+9 ;DOB
SET $PIECE(BDGZ,BDGDLIM,4)=Y
+10 SET $PIECE(BDGZ,BDGDLIM,5)=BDGIEN
+11 SET $PIECE(BDGZ,BDGDLIM,6)=$$STATUS(BDGIEN)
+12 SET $PIECE(BDGZ,BDGDLIM,7)=$$SEX^AUPNPAT(BDGIEN)_"^"_$$INP(BDGIEN)
+13 ;get city
SET $PIECE(BDGZ,BDGDLIM,21)=$$GET1^DIQ(2,BDGIEN_",",.114)
+14 ;get state
SET $PIECE(BDGZ,BDGDLIM,22)=$$GET1^DIQ(2,BDGIEN_",",.115)
+15 ; Date of Death
SET DFN=BDGIEN
IF $GET(DFN)
SET $PIECE(BDGZ,BDGDLIM,20)=$$DOD^AUPNPAT(DFN)
+16 SET @BDGY@(BDGXI)=BDGZ
SET BDGXI=BDGXI+1
+17 QUIT
STATUS(DFN,CHECK) ;
+1 NEW STATUS,A,INP
+2 IF 'DFN
QUIT ""
+3 KILL VAIN
+4 IF $GET(CHECK)
Begin DoDot:1
+5 DO IN5^VADPT
+6 IF $GET(VAIP(1))
SET INP=1
QUIT
+7 SET INP=0
End DoDot:1
QUIT INP
+8 DO INP^DGPMV10
DO Q^VADPT3
+9 SET A=$SELECT("^3^5^"[("^"_+DGPMVI(2)_"^"):0,1:+DGPMVI(2))
+10 SET STATUS=$SELECT('A:"IN",1:"")_"ACTIVE "_$SELECT("^4^5^"[("^"_+DGPMVI(2)_"^"):"LODGER",$PIECE(DGPMVI(8),"^",2)["OBSERVATION":"OBSERVATION PATIENT",1:"INPATIENT")
+11 QUIT STATUS
INP(DFN) ;
+1 NEW BDGINP,BDGWARD,BDGRMBD,BDGIEN,BDGTRSP,BDGPPHYS,BDGAPHYS,BDGLEBY,BDGLEON,BDGADIS,BDGDIST,BDGADMPV
+2 NEW BDGARY
+3 KILL VAIN
+4 SET BDGINP=0
+5 DO INP^VADPT
MERGE BDGARY=VAIN
+6 SET BDGIEN=+$GET(VAIN(1))
IF BDGIEN
SET BDGINP=1
+7 IF 'BDGINP
DO INP^DGPMV10
SET BDGDIEN=$GET(DGPMVI(1))
+8 IF 'BDGINP
SET BDGIEN=$$GET1^DIQ(405,BDGDIEN,.14,"I")
+9 SET BDGLEBY=$$GET1^DIQ(405,$SELECT(BDGINP:BDGIEN,1:BDGDIEN),102,"I")
+10 SET BDGLEON=$$GET1^DIQ(405,$SELECT(BDGINP:BDGIEN,1:BDGDIEN),103,"I")
+11 SET BDGPPHYS=$PIECE(BDGARY(2),U)
+12 SET BDGTRSP=$PIECE(BDGARY(3),U)
+13 SET BDGWARD=$PIECE(BDGARY(4),U)
+14 SET BDGRMBD=$PIECE(BDGARY(5),U)
IF BDGRMBD]""
SET BDGRMBD=$ORDER(^DG(405.4,"B",BDGRMBD,0))
+15 SET BDGAPHYS=$PIECE(BDGARY(11),U)
+16 SET BDGADIS=$$GET1^DIQ(405,BDGIEN,.17,"I")
+17 IF BDGADIS
Begin DoDot:1
+18 SET BDGDIST=$$GET1^DIQ(405,BDGADIS,.04,"E")
End DoDot:1
+19 SET BDGADMPV=$$GET1^DIQ(405,BDGIEN,9999999.02,"E")
+20 QUIT BDGIEN_U_BDGINP_U_BDGWARD_U_BDGRMBD_U_BDGTRSP_U_BDGPPHYS_U_BDGAPHYS_U_BDGADMPV_U_BDGLEBY_U_BDGLEON_U_BDGADIS_U_$GET(BDGDIST)
+21 ;
