BEHOENP1 ;MSC/IND/DKM - Retrieve PCC data for a visit ;03-Jun-2014 12:24;DU
;;1.1;BEH COMPONENTS;**005002,005004,005011,005012**;Sep 18, 2007
;=================================================================
; RPC: Return PCC data for an associated visit
LOAD(DATA,DFN,VIEN) ;EP
N VSTR,LOC,VTYP,ICNT,ICOM,X0
Q:VIEN'>0
S VSTR=$$VIS2VSTR^BEHOENCX(DFN,VIEN)
Q:'$L(VSTR)
S VTYP=$P(VSTR,";",3),(ICNT,ICOM)=0
Q:VTYP="H"
; Visit data
D ADD("HDR"_U_("ID"[VTYP)_U_U_VSTR)
S X0=^AUPNVSIT(VIEN,0),LOC=+$P(X0,U,22)
D ADD("VST^DT^"_$P(X0,U))
D ADD("VST^PT^"_$P(X0,U,5))
D ADD("VST^HL^"_LOC_"^^"_$P($G(^SC(LOC,0)),U))
D ADD("VST^PS^0") ;outpt
D GET(9000010.06,"PRV")
D GET(9000010.07,"POV")
D GET(9000010.18,"CPT")
D GET(9000010.11,"IMM")
D GET(9000010.12,"SK")
D GET(9000010.16,"PED")
D GET(9000010.23,"HF")
D GET(9000010.13,"XAM")
D GET(9000010.15,"TRT")
D GET(9000010.01,"MSR")
D GET(120.5,"VIT")
Q
; Fetch V File data
GET(VF,TAG) ;
N LP,PC
S PC=$S(VF=120.5:3,1:1)
S VF=$$ROOT^DILFD(VF,,1)
Q:'$L(VF)
S LP=0
F S LP=$O(@VF@("AD",VIEN,LP)) Q:'LP D
.N X,CODE,CMNT,PRV,CAT
.M X=@VF@(LP)
.Q:$P(X(0),U,2)'=DFN
.S CODE=$P(X(0),U,PC),CMNT=$G(X(811)),PRV=$P($G(X(12)),U,4),CAT=$P($G(X(802)),U)
.S CAT=$S(CAT:$P(^AUTNPOV(CAT,0),U),1:"")
.D @TAG
Q
; V PROVIDER
; PRV^ien^^^name^primary/secondary flag
PRV N NARR,PRIM
S NARR=$P($G(^VA(200,CODE,0)),U)
S PRIM=($P(X(0),U,4)="P")
D ADD(TAG_U_CODE_"^^^"_NARR_U_PRIM)
Q
; V POV
; POV^ien^CAT^narrative^com^prv^primary
POV N NARR,PRIM,VDATE
;IHS/MSC/MGH Changes for ICD-10 update
I CODE D
.S VDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
.I $$AICD^BEHOENPC S CODE=$P($$ICDDX^ICDEX(CODE,VDATE),U,2)
.E S CODE=$P($$ICDDX^ICDCODE(CODE,VDATE),U,2)
;S CODE=$P(^ICD9(CODE,0),U)
;S NARR=$P(X(0),U,4)
S NARR=$$GET1^DIQ(9000010.07,LP,.04)
I $P(NARR,"|",2)="" S NARR=$P(NARR,"|",1)
;S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
S PRIM=$P(X(0),U,12)="P"
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_PRIM,CMNT)
Q
; V CPT
; CPT^ien^cat^nar^com^prv^qty^mods
CPT N NARR,QTY,MCNT,MIDX,MODS,MIEN
S CODE=$O(^ICPT("B",CODE,0))
S:CODE CODE=$P(^ICPT(CODE,0),U)
S NARR=$P(X(0),U,4)
S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
S QTY=$P(X(0),U,16)
S MCNT=0,MIDX=0,MODS=""
F S MIDX=$O(X(1,MIDX)) Q:'MIDX D
.S MIEN=X(1,MIDX,0)
.S:MIEN MCNT=MCNT+1,MODS=MODS_";/"_MIEN
S:MCNT MODS=MCNT_MODS
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_MODS,CMNT)
Q
; V IMMUNIZATION
; IMM^ien^cat^nar^com^prv^Series^Reaction^Contraindicated^Refused^LotNum^Site^Volume^VISDate
IMM N NARR,QTY,REF
S:CODE NARR=$P(^AUTTIMM(CODE,0),U)
S QTY=$P(X(0),U,4)
S REF=$$REFUSAL(9999999.14,CODE,LP)
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$P(X(0),U,6)_U_$P(X(0),U,7)_U_REF_U_$P(X(0),U,5)_U_$P(X(0),U,9)_U_$P(X(0),U,11)_U_$P(X(0),U,12),CMNT)
Q
; V SKIN TEST
; SK^ien^cat^nar^com^prv^Result^Reading^D/T read^D/T given^Read by^Refused
SK N NARR,QTY,REF
S:CODE NARR=$P(^AUTTSK(CODE,0),U)
S QTY=$P(X(0),U,4)
S REF=$$REFUSAL(9999999.28,CODE,LP)
;IHS/MSC/MGH added $G for missing entry date/time
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$P(X(0),U,5)_U_$P(X(0),U,6)_U_$P($G(X(12)),U)_U_$P(X(0),U,8)_U_REF,CMNT)
Q
; V PATIENT ED
; PED^ien^cat^nar^com^prv^Level of understanding^Refused^Elapsed^Setting^Goals^Outcome
PED N NARR,QTY,REF,SNO,Z,TXT,IN
Q:'CODE
S NARR=$P(^AUTTEDT(CODE,0),U)
;IHS/MSC/MGH Updated for SNOMED education
I $P($G(^AUTTEDT(CODE,0)),U,12)'="" D
.S TXT=""
.S SNO=$P($G(^AUTTEDT(CODE,0)),U,12)
.S IN=SNO_U_36_U_U_1
.S Z=$$CONC^BSTSAPI(IN)
.S TXT=$P(Z,U,4)
.I $L(TXT) S NARR=TXT_"-"_$P($P($G(^AUTTEDT(CODE,0)),U,1),"-",2)
S QTY=$P(X(0),U,6)
S REF=$$REFUSAL(9999999.09,CODE,LP)
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF_U_$P(X(0),U,8)_U_$P(X(0),U,7)_U_$P(X(0),U,13)_U_$P(X(0),U,14),CMNT)
Q
; V HEALTH FACTOR
; HF^ien^cat^nar^com^prv^Level/severity
HF N NARR,QTY
S:CODE NARR=$P(^AUTTHF(CODE,0),U)
S QTY=$P(X(0),U,4)
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
Q
; V EXAM
; XAM^ien^cat^nar^com^prv^Result^Refused
XAM N NARR,QTY,REF
S:CODE NARR=$P(^AUTTEXAM(CODE,0),U)
S QTY=$P(X(0),U,4)
S REF=$$REFUSAL(9999999.15,CODE,LP)
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF,CMNT)
Q
; V TREATMENT
; TRT^ien^cat^nar^com^prv^qty
TRT N QTY,NARR
S QTY=$P(X(0),U,4)
S NARR=$P(X(0),U,6)
S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
D ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
Q
; V MEASUREMENT
MSR N NARR,VAL,EIE
S:CODE NARR=$P(^AUTTMSR(CODE,0),U)
S VAL=$P(X(0),U,4)
S EIE=$P($G(X(2)),U,1)
Q:EIE=1
D ADD(TAG_U_CODE_U_CAT_U_$G(NARR)_U_U_PRV_U_VAL)
Q
; GMRV VITAL MEASUREMENT
VIT N NARR,VAL
S:CODE NARR=$P(^GMRD(120.51,CODE,0),U,7)
S VAL=$P(X(0),U,8)
D ADD("MSR^"_CODE_U_CAT_U_$G(NARR)_U_U_PRV_U_VAL)
Q
; Add to return array
ADD(X,C) S:$L($G(C)) ICOM=ICOM+1,$P(X,U,5)=ICOM
S ICNT=ICNT+1,@DATA@(ICNT)=X
D:$L($G(C)) ADD("COM"_U_ICOM_U_C)
Q
; Look for a refusal of specified type
; FNUM = File # of PCC type file
; CODE = IEN in PCC type file
; VISIT= IEN in visit file
; .IEN = Returned IEN of entry in refusal file (or 0 if none)
; Returns internal value of refusal reason or null
REFUSAL(FNUM,CODE,VISIT,IEN) ;EP
N DAT,DFN,X
S X=$G(^AUPNVSIT(VISIT,0)),DAT=X\1,DFN=$P(X,U,5),IEN=0
I FNUM,CODE,DAT,DFN D
.S IEN=$O(^AUPNPREF("AA",DFN,FNUM,CODE,9999999-DAT,0))
Q:$Q $S(IEN:$P($G(^AUPNPREF(IEN,0)),U,7),1:"")
Q
; RPC: Return the default values for an immunization
; IMM = IEN in IMMUNIZATION file
; Returns:
; VIS Date^Volume^Lot #
IMMDFLTS(DATA,IMM) ;EP
N X,VOL
S X=$G(^AUTTIMM(+$G(IMM),0))
S $P(DATA,U)=$P(X,U,13)
;S $P(DATA,U,2)=$P(X,U,18)
;IHS/MSC/MGH modified to add leading zeros
S VOL=$P(X,U,18) I $E(VOL,1,1)="." S VOL="0"_VOL
S $P(DATA,U,2)=VOL
S $P(DATA,U,3)=$$GET1^DIQ(9999999.41,+$P(X,U,4),.01)
Q
; Lot # screen
IMMLOTSC(LOT,IMM) ;EP
N X,I
S X=$G(^AUTTIML(+LOT,0))
Q:'$L(X)!$P(X,U,3) 0
F I=4:1:8 I $P(X,U,I)=IMM S I=-1 Q
;IHS/MSC/MGH P14 Facility specific lot
Q:(($P(X,U,14))&($P(X,U,14)'=$G(DUZ(2)))) 0
Q $S(I=-1:1,1:0)
;Elig screen
IMMELIG(CODE) ;EP
N X
S X=$G(^BIELIG(CODE,0))
Q '$P(X,U,3)
BEHOENP1 ;MSC/IND/DKM - Retrieve PCC data for a visit ;03-Jun-2014 12:24;DU
+1 ;;1.1;BEH COMPONENTS;**005002,005004,005011,005012**;Sep 18, 2007
+2 ;=================================================================
+3 ; RPC: Return PCC data for an associated visit
LOAD(DATA,DFN,VIEN) ;EP
+1 NEW VSTR,LOC,VTYP,ICNT,ICOM,X0
+2 IF VIEN'>0
QUIT
+3 SET VSTR=$$VIS2VSTR^BEHOENCX(DFN,VIEN)
+4 IF '$LENGTH(VSTR)
QUIT
+5 SET VTYP=$PIECE(VSTR,";",3)
SET (ICNT,ICOM)=0
+6 IF VTYP="H"
QUIT
+7 ; Visit data
+8 DO ADD("HDR"_U_("ID"[VTYP)_U_U_VSTR)
+9 SET X0=^AUPNVSIT(VIEN,0)
SET LOC=+$PIECE(X0,U,22)
+10 DO ADD("VST^DT^"_$PIECE(X0,U))
+11 DO ADD("VST^PT^"_$PIECE(X0,U,5))
+12 DO ADD("VST^HL^"_LOC_"^^"_$PIECE($GET(^SC(LOC,0)),U))
+13 ;outpt
DO ADD("VST^PS^0")
+14 DO GET(9000010.06,"PRV")
+15 DO GET(9000010.07,"POV")
+16 DO GET(9000010.18,"CPT")
+17 DO GET(9000010.11,"IMM")
+18 DO GET(9000010.12,"SK")
+19 DO GET(9000010.16,"PED")
+20 DO GET(9000010.23,"HF")
+21 DO GET(9000010.13,"XAM")
+22 DO GET(9000010.15,"TRT")
+23 DO GET(9000010.01,"MSR")
+24 DO GET(120.5,"VIT")
+25 QUIT
+26 ; Fetch V File data
GET(VF,TAG) ;
+1 NEW LP,PC
+2 SET PC=$SELECT(VF=120.5:3,1:1)
+3 SET VF=$$ROOT^DILFD(VF,,1)
+4 IF '$LENGTH(VF)
QUIT
+5 SET LP=0
+6 FOR
SET LP=$ORDER(@VF@("AD",VIEN,LP))
IF 'LP
QUIT
Begin DoDot:1
+7 NEW X,CODE,CMNT,PRV,CAT
+8 MERGE X=@VF@(LP)
+9 IF $PIECE(X(0),U,2)'=DFN
QUIT
+10 SET CODE=$PIECE(X(0),U,PC)
SET CMNT=$GET(X(811))
SET PRV=$PIECE($GET(X(12)),U,4)
SET CAT=$PIECE($GET(X(802)),U)
+11 SET CAT=$SELECT(CAT:$PIECE(^AUTNPOV(CAT,0),U),1:"")
+12 DO @TAG
End DoDot:1
+13 QUIT
+14 ; V PROVIDER
+15 ; PRV^ien^^^name^primary/secondary flag
PRV NEW NARR,PRIM
+1 SET NARR=$PIECE($GET(^VA(200,CODE,0)),U)
+2 SET PRIM=($PIECE(X(0),U,4)="P")
+3 DO ADD(TAG_U_CODE_"^^^"_NARR_U_PRIM)
+4 QUIT
+5 ; V POV
+6 ; POV^ien^CAT^narrative^com^prv^primary
POV NEW NARR,PRIM,VDATE
+1 ;IHS/MSC/MGH Changes for ICD-10 update
+2 IF CODE
Begin DoDot:1
+3 SET VDATE=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
+4 IF $$AICD^BEHOENPC
SET CODE=$PIECE($$ICDDX^ICDEX(CODE,VDATE),U,2)
+5 IF '$TEST
SET CODE=$PIECE($$ICDDX^ICDCODE(CODE,VDATE),U,2)
End DoDot:1
+6 ;S CODE=$P(^ICD9(CODE,0),U)
+7 ;S NARR=$P(X(0),U,4)
+8 SET NARR=$$GET1^DIQ(9000010.07,LP,.04)
+9 IF $PIECE(NARR,"|",2)=""
SET NARR=$PIECE(NARR,"|",1)
+10 ;S:NARR NARR=$P(^AUTNPOV(NARR,0),U)
+11 SET PRIM=$PIECE(X(0),U,12)="P"
+12 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_PRIM,CMNT)
+13 QUIT
+14 ; V CPT
+15 ; CPT^ien^cat^nar^com^prv^qty^mods
CPT NEW NARR,QTY,MCNT,MIDX,MODS,MIEN
+1 SET CODE=$ORDER(^ICPT("B",CODE,0))
+2 IF CODE
SET CODE=$PIECE(^ICPT(CODE,0),U)
+3 SET NARR=$PIECE(X(0),U,4)
+4 IF NARR
SET NARR=$PIECE(^AUTNPOV(NARR,0),U)
+5 SET QTY=$PIECE(X(0),U,16)
+6 SET MCNT=0
SET MIDX=0
SET MODS=""
+7 FOR
SET MIDX=$ORDER(X(1,MIDX))
IF 'MIDX
QUIT
Begin DoDot:1
+8 SET MIEN=X(1,MIDX,0)
+9 IF MIEN
SET MCNT=MCNT+1
SET MODS=MODS_";/"_MIEN
End DoDot:1
+10 IF MCNT
SET MODS=MCNT_MODS
+11 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_MODS,CMNT)
+12 QUIT
+13 ; V IMMUNIZATION
+14 ; IMM^ien^cat^nar^com^prv^Series^Reaction^Contraindicated^Refused^LotNum^Site^Volume^VISDate
IMM NEW NARR,QTY,REF
+1 IF CODE
SET NARR=$PIECE(^AUTTIMM(CODE,0),U)
+2 SET QTY=$PIECE(X(0),U,4)
+3 SET REF=$$REFUSAL(9999999.14,CODE,LP)
+4 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$PIECE(X(0),U,6)_U_$PIECE(X(0),U,7)_U_REF_U_$PIECE(X(0),U,5)_U_$PIECE(X(0),U,9)_U_$PIECE(X(0),U,11)_U_$PIECE(X(0),U,12),CMNT)
+5 QUIT
+6 ; V SKIN TEST
+7 ; SK^ien^cat^nar^com^prv^Result^Reading^D/T read^D/T given^Read by^Refused
SK NEW NARR,QTY,REF
+1 IF CODE
SET NARR=$PIECE(^AUTTSK(CODE,0),U)
+2 SET QTY=$PIECE(X(0),U,4)
+3 SET REF=$$REFUSAL(9999999.28,CODE,LP)
+4 ;IHS/MSC/MGH added $G for missing entry date/time
+5 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_$PIECE(X(0),U,5)_U_$PIECE(X(0),U,6)_U_$PIECE($GET(X(12)),U)_U_$PIECE(X(0),U,8)_U_REF,CMNT)
+6 QUIT
+7 ; V PATIENT ED
+8 ; PED^ien^cat^nar^com^prv^Level of understanding^Refused^Elapsed^Setting^Goals^Outcome
PED NEW NARR,QTY,REF,SNO,Z,TXT,IN
+1 IF 'CODE
QUIT
+2 SET NARR=$PIECE(^AUTTEDT(CODE,0),U)
+3 ;IHS/MSC/MGH Updated for SNOMED education
+4 IF $PIECE($GET(^AUTTEDT(CODE,0)),U,12)'=""
Begin DoDot:1
+5 SET TXT=""
+6 SET SNO=$PIECE($GET(^AUTTEDT(CODE,0)),U,12)
+7 SET IN=SNO_U_36_U_U_1
+8 SET Z=$$CONC^BSTSAPI(IN)
+9 SET TXT=$PIECE(Z,U,4)
+10 IF $LENGTH(TXT)
SET NARR=TXT_"-"_$PIECE($PIECE($GET(^AUTTEDT(CODE,0)),U,1),"-",2)
End DoDot:1
+11 SET QTY=$PIECE(X(0),U,6)
+12 SET REF=$$REFUSAL(9999999.09,CODE,LP)
+13 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF_U_$PIECE(X(0),U,8)_U_$PIECE(X(0),U,7)_U_$PIECE(X(0),U,13)_U_$PIECE(X(0),U,14),CMNT)
+14 QUIT
+15 ; V HEALTH FACTOR
+16 ; HF^ien^cat^nar^com^prv^Level/severity
HF NEW NARR,QTY
+1 IF CODE
SET NARR=$PIECE(^AUTTHF(CODE,0),U)
+2 SET QTY=$PIECE(X(0),U,4)
+3 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
+4 QUIT
+5 ; V EXAM
+6 ; XAM^ien^cat^nar^com^prv^Result^Refused
XAM NEW NARR,QTY,REF
+1 IF CODE
SET NARR=$PIECE(^AUTTEXAM(CODE,0),U)
+2 SET QTY=$PIECE(X(0),U,4)
+3 SET REF=$$REFUSAL(9999999.15,CODE,LP)
+4 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY_U_REF,CMNT)
+5 QUIT
+6 ; V TREATMENT
+7 ; TRT^ien^cat^nar^com^prv^qty
TRT NEW QTY,NARR
+1 SET QTY=$PIECE(X(0),U,4)
+2 SET NARR=$PIECE(X(0),U,6)
+3 IF NARR
SET NARR=$PIECE(^AUTNPOV(NARR,0),U)
+4 DO ADD(TAG_U_CODE_U_CAT_U_NARR_U_U_PRV_U_QTY,CMNT)
+5 QUIT
+6 ; V MEASUREMENT
MSR NEW NARR,VAL,EIE
+1 IF CODE
SET NARR=$PIECE(^AUTTMSR(CODE,0),U)
+2 SET VAL=$PIECE(X(0),U,4)
+3 SET EIE=$PIECE($GET(X(2)),U,1)
+4 IF EIE=1
QUIT
+5 DO ADD(TAG_U_CODE_U_CAT_U_$GET(NARR)_U_U_PRV_U_VAL)
+6 QUIT
+7 ; GMRV VITAL MEASUREMENT
VIT NEW NARR,VAL
+1 IF CODE
SET NARR=$PIECE(^GMRD(120.51,CODE,0),U,7)
+2 SET VAL=$PIECE(X(0),U,8)
+3 DO ADD("MSR^"_CODE_U_CAT_U_$GET(NARR)_U_U_PRV_U_VAL)
+4 QUIT
+5 ; Add to return array
ADD(X,C) IF $LENGTH($GET(C))
SET ICOM=ICOM+1
SET $PIECE(X,U,5)=ICOM
+1 SET ICNT=ICNT+1
SET @DATA@(ICNT)=X
+2 IF $LENGTH($GET(C))
DO ADD("COM"_U_ICOM_U_C)
+3 QUIT
+4 ; Look for a refusal of specified type
+5 ; FNUM = File # of PCC type file
+6 ; CODE = IEN in PCC type file
+7 ; VISIT= IEN in visit file
+8 ; .IEN = Returned IEN of entry in refusal file (or 0 if none)
+9 ; Returns internal value of refusal reason or null
REFUSAL(FNUM,CODE,VISIT,IEN) ;EP
+1 NEW DAT,DFN,X
+2 SET X=$GET(^AUPNVSIT(VISIT,0))
SET DAT=X\1
SET DFN=$PIECE(X,U,5)
SET IEN=0
+3 IF FNUM
IF CODE
IF DAT
IF DFN
Begin DoDot:1
+4 SET IEN=$ORDER(^AUPNPREF("AA",DFN,FNUM,CODE,9999999-DAT,0))
End DoDot:1
+5 IF $QUIT
QUIT $SELECT(IEN:$PIECE($GET(^AUPNPREF(IEN,0)),U,7),1:"")
+6 QUIT
+7 ; RPC: Return the default values for an immunization
+8 ; IMM = IEN in IMMUNIZATION file
+9 ; Returns:
+10 ; VIS Date^Volume^Lot #
IMMDFLTS(DATA,IMM) ;EP
+1 NEW X,VOL
+2 SET X=$GET">GET(^AUTTIMM(+$GET">GET(IMM),0))
+3 SET $PIECE(DATA,U)=$PIECE(X,U,13)
+4 ;S $P(DATA,U,2)=$P(X,U,18)
+5 ;IHS/MSC/MGH modified to add leading zeros
+6 SET VOL=$PIECE(X,U,18)
IF $EXTRACT(VOL,1,1)="."
SET VOL="0"_VOL
+7 SET $PIECE(DATA,U,2)=VOL
+8 SET $PIECE(DATA,U,3)=$$GET1^DIQ(9999999.41,+$PIECE(X,U,4),.01)
+9 QUIT
+10 ; Lot # screen
IMMLOTSC(LOT,IMM) ;EP
+1 NEW X,I
+2 SET X=$GET(^AUTTIML(+LOT,0))
+3 IF '$LENGTH(X)!$PIECE(X,U,3)
QUIT 0
+4 FOR I=4:1:8
IF $PIECE(X,U,I)=IMM
SET I=-1
QUIT
+5 ;IHS/MSC/MGH P14 Facility specific lot
+6 IF (($PIECE(X,U,14))&($PIECE(X,U,14)'=$GET(DUZ(2))))
QUIT 0
+7 QUIT $SELECT(I=-1:1,1:0)
+8 ;Elig screen
IMMELIG(CODE) ;EP
+1 NEW X
+2 SET X=$GET(^BIELIG(CODE,0))
+3 QUIT '$PIECE(X,U,3)
