BDGF1 ; IHS/ANMC/LJF - INPT DATA FUNCTION CALLS ; [ 09/23/2004 5:04 PM ]
;;5.3;PIMS;**1001,1004,1006**;MAY 28, 2004
;IHS/ITSC/WAR 09/23/2004 PATCH 1001 use attending provider in PCC if there
;IHS/OIT/LJF 07/15/2005 PATCH 1004 fixed inverse date code
; 09/09/2005 PATCH 1004 added SRVCHK subroutine
; 08/31/2006 PATCH 1006 added DESC subroutine
;
; PAT=PAT of patient
; ADM=admission ien, also called corresponding admission (CA)
;
VISIT(PAT,DATE) ;PEP; return H or O visit ien for patient and admit date
NEW RVDT,V,X,FOUND
S RVDT=9999999-$P(DATE,".")_"."_$P(DATE,".",2)
S FOUND=0
S V=0 F S V=$O(^AUPNVSIT("AA",PAT,RVDT,V)) Q:'V Q:FOUND D
. S X=$$GET1^DIQ(9000010,V,.07,"I") I (X="H")!(X="O") S FOUND=V
Q $G(FOUND)
;
INPT1(PAT,DATE) ;PEP; returns admit date (external format) if inpt on DATE sent
NEW ADM,DSCH
S ADM=$O(^DGPM("ATID1",PAT,9999999-DATE)) I ADM="" Q ""
;S DSCH=$O(^DGPM("APTT3",PAT,9999999-ADM))
S DSCH=$O(^DGPM("APTT3",PAT,9999999.9999999-ADM)) ;IHS/OIT/LJF 7/15/2005 PATCH 1004
I DSCH]""&(DSCH<DATE) Q ""
S ADM=9999999.99999999-ADM
Q $$NUMDATE^BDGF(ADM,1)
;
ADMTXN(ADM,PAT) ;PEP; -- returns treating specialty node ien for admission
;called by ADT ITEMS file
NEW DATE
S DATE=+$G(^DGPM(ADM,0)) I 'DATE Q 0
Q +$O(^DGPM("APTT6",PAT,DATE,0))
;
ADMPRV(ADM,PAT,TYPE,MODE) ;PEP; -- returns provider for admission based on type
; TYPE="ADM" for admitting, "PRM" for primary, "ATT" for attending
; MODE="" for external format or ="I" for internal format
;called by ADT ITEMS file
NEW IEN,FIELD
I ('ADM)!('PAT) Q ""
S IEN=$$ADMTXN(ADM,PAT) I 'IEN Q ""
S FIELD=$S(TYPE="ADM":9999999.02,TYPE="ATT":.19,1:.08)
Q $$GET1^DIQ(405,IEN,FIELD,$G(MODE))
;
ADMPRVS(ADM,PAT,TYPE,MODE) ;PEP; -- returns provider's service based on type
; TYPE="ADM" for admitting, "PRM" for primary, "ATT" for attending
; MODE="" for external format or ="I" for internal format
Q $$GET1^DIQ(200,+$$ADMPRV(ADM,PAT,TYPE,"I"),29,$G(MODE))
;
ADMSRV(ADM,PAT) ;PEP; -- returns admitting service name
NEW IEN
I ('ADM)!('PAT) Q ""
S IEN=$$ADMTXN(ADM,PAT) I 'IEN Q ""
Q $$GET1^DIQ(405,IEN,.09)
;
ADMSRVN(ADM,PAT) ;PEP; -- returns admitting service ien
NEW IEN
I ('ADM)!('PAT) Q ""
S IEN=$$ADMTXN(ADM,PAT) I 'IEN Q ""
Q $$GET1^DIQ(405,IEN,.09,"I")
;
ADMSRVC(ADM,PAT) ;PEP; returns admitting service abbrev & code
;called by ADT ITEMS file
NEW IEN,X
I ('ADM)!('PAT) Q ""
S IEN=$$ADMSRVN(ADM,PAT) I 'IEN Q ""
S X=$$GET1^DIQ(45.7,IEN,99) S:X="" X="??"
Q X_" "_$$GET1^DIQ(45.7,IEN,9999999.01)
;
ADMTYP(ADM) ;PEP; returns IHS admit type and code
;called by ADT ITEMS file
NEW X
I '$G(ADM) Q "??"
S X=$$GET1^DIQ(405,ADM,.04,"I") I 'X Q "??" ;internal
S X=$$GET1^DIQ(405.1,X,9999999.1)
Q X_" "_$$GET1^DIQ(405,ADM,.04)
;
WRDABRV(PAT) ;PEP; returns abbreviation of current ward
I $G(^DPT(PAT,.1))="" Q ""
NEW X S X=^DPT(PAT,.1),X=$O(^DIC(42,"B",X,0)) I 'X Q ""
Q $$GET1^DIQ(9009016.5,X,.02)
;
WRDABRV2(N) ;PEP; returns abbreviation of ward for movement N
NEW X
S X=$$GET1^DIQ(405,N,.06,"I") I 'X Q ""
Q $$GET1^DIQ(9009016.5,X,.02)
;
CURPRV(PAT,LENGTH) ;PEP; returns current attending provider for patient
; LENGTH=amount of room to fit name, optional
NEW Y S Y=$$GET1^DIQ(2,PAT,.1041)
I '$G(LENGTH) S LENGTH=20
Q $E(Y,1,LENGTH)
;
CURDX(PAT) ;PEP; returns admitting dx for current inpatient
NEW CA
S CA=$G(^DPT(PAT,.105)) I 'CA Q "??"
Q $$GET1^DIQ(405,CA,.1)
;
CURLOS(PAT,MODE) ;PEP; returns length of stay for current inpatient
; MODE=1 means return observation in hours
NEW CA,SRV
S CA=$G(^DPT(PAT,.105)) I 'CA Q "??"
S SRV=$$GET1^DIQ(2,PAT,.103)
I $G(MODE),SRV["OBSERVATION" Q $$LOSHRS(CA,$$NOW^XLFDT,PAT)_" hrs"
Q $$GET1^DIQ(405,CA,201)_" days"
;
LASTTXN(ADM,PAT) ;PEP; returns last treating specialty ien for admission
; also returns last service as second U piece
NEW DSC,DATE,SRV,IEN
I ('ADM)!('PAT) Q 0
S DSC=$$GET1^DIQ(405,ADM,.17,"I") ;find discharge if there
; start at discharge date or beginning if still inpt
S DATE=$S(DSC="":0,1:9999999.9999999-$G(^DGPM(DSC,0)))
; find date of last treating specialty change
S DATE=$O(^DGPM("ATS",PAT,ADM,DATE)) I 'DATE Q 0
; find treating specialty ien
S SRV=$O(^DGPM("ATS",PAT,ADM,DATE,0)) I 'SRV Q 0
; find treating specialty change ien
S IEN=$O(^DGPM("ATS",PAT,ADM,DATE,SRV,0)) I 'IEN Q 0
Q IEN_U_SRV
;
LASTSRVN(ADM,PAT) ;PEP; returns last service name
I ('ADM)!('PAT) Q ""
NEW X
S X=$P($$LASTTXN(ADM,PAT),U,2) I 'X Q ""
Q $$GET1^DIQ(45.7,X,.01)
;
LASTSRVC(ADM,PAT) ;PEP; returns last service abbreviation and its code
;called by ADT ITEMS file
I ('ADM)!('PAT) Q ""
NEW X
S X=$P($$LASTTXN(ADM,PAT),U,2) I 'X Q ""
Q $$GET1^DIQ(45.7,X,99)_" "_$$GET1^DIQ(45.7,X,9999999.01)
;
LASTPRV(ADM,PAT,MODE) ;PEP; returns last attending provider based on type
; MODE="" for external format or ="I" for internal format
;called by ADT ITEMS file
NEW LAST
S LAST=$$LASTTXN(ADM,PAT) I 'LAST Q "??"
;
;IHS/ITSC/WAR 9/23/04 PATCH #1001 Added next 2 lines per LJF
NEW VST,PCC S VST=$$GET1^DIQ(405,+ADM,.27,"I")
I VST S PCC=$$PRIMPROV^APCLV(VST,$S($G(MODE)="":"N",1:MODE)) I PCC]"" Q PCC
;IHS/ITSC/WAR end of 9/23/04 mod
;
Q $$GET1^DIQ(405,+LAST,.19,$G(MODE))
;
LASTPRVC(ADM,PAT) ;PEP; returns IHS ADC code for last attending provider by type
;called by ADT ITEMS file
Q $$GET1^DIQ(200,+$$LASTPRV(ADM,PAT,"I"),9999999.09)
;
LASTPRVS(ADM,PAT,MODE) ;PEP; returns last attending provider's service
; MODE="" for external format or ="I" for internal format
Q $$GET1^DIQ(200,+$$LASTPRV(ADM,PAT,"I"),29,$G(MODE))
;
PRIORTXN(DATE,CA,PAT) ;PEP; returns treating specialty ien prior to date sent
; assumes date includes time
NEW LAST,FOUND
I ('DATE)!('PAT) Q 0
;
; if date=admit date, use admit service ien
I DATE=+$G(^DGPM(CA,0)) Q +$O(^DGPM("APTT6",PAT,DATE,0))
;
; find last service change (not provider change only)
S LAST=DATE,FOUND=0
F S LAST=$O(^DGPM("APTT6",PAT,LAST),-1) Q:'LAST Q:FOUND D
. S N=$O(^DGPM("APTT6",PAT,LAST,0)) Q:'N
. I $P($G(^DGPM(N,0)),U,9)]"" S FOUND=LAST ;has service
;
I 'FOUND Q $$ADMTXN(CA,PAT) ;return admit service
Q +$O(^DGPM("APTT6",PAT,FOUND,0))
;
PRIORMVT(DATE,CA,PAT) ;PEP; returns last physical movement before DATE
NEW LAST
I ('DATE)!('CA)!('PAT) Q 0
S LAST=$O(^DGPM("APCA",PAT,CA,DATE),-1) I 'LAST Q CA
Q +$O(^DGPM("APCA",PAT,CA,LAST,0))
;
LOSHRS(CA,DATE,PAT) ;PEP; returns length of stay in hours
Q $J($$FMDIFF^XLFDT(DATE,+$G(^DGPM(CA,0)),2)/3600,0,0)
;
READM(ADM,PAT,LIMIT) ;PEP; returns 1 if patient readmitted within parameter limit
; LIMIT is optional, if not sent will use site parameter
; returns LAST discharge date if within limits
NEW ADMDT,LAST,DIFF
S ADMDT=$$GET1^DIQ(405,ADM,.01,"I") ;new admit date
I 'ADMDT Q 0 ;bad entry
S LAST=$O(^DGPM("APTT3",PAT,ADMDT),-1) ;last discharge
I 'LAST Q 0 ;1st admission
S DIFF=$$FMDIFF^XLFDT(ADMDT,LAST) ;# of days diff
;
; if limit was sent
I $G(LIMIT)'="",DIFF>LIMIT Q 0
;
; if using site parameter
I $G(LIMIT)="",DIFF>$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),105) Q 0
;
Q 1_U_LAST
;
DSADM(ADM,PAT) ;PEP; returns 1 if patient admitted after day surgery w/in limit
NEW ADMDT,LAST,DIFF
S ADMDT=$$GET1^DIQ(405,ADM,.01,"I") ;new admit date
S LAST=$$LASTDS^BDGDSA(ADMDT,PAT) ;last day surgery
I 'LAST Q 0 ;1st admission
S DIFF=$$FMDIFF^XLFDT(ADMDT,LAST) ;# of days diff
I DIFF>$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),107) Q 0
Q 1_U_LAST
;
LASTADM(PAT) ; Returns ien for patient's most recent admission
NEW Y
S Y=$O(^DGPM("ATID1",PAT,0)) I 'Y Q 0
Q +$O(^DGPM("ATID1",PAT,Y,0))
;
OPTOUT(PAT) ;EP; returns 1 if patient asked to opt-out of directory for current admission
NEW X
S X=$$GET1^DIQ(2,PAT,.105,"I") I 'X Q 0 ;get admission ien
Q +$$GET1^DIQ(405,X,41,"I") ;directory exclusion field
;
;IHS/OIT/LJF 09/09/2005 PATCH 1004 added new subroutine
SRVCHK(SRV,IEN) ;EP; called by 405 DD on field .09
; Make sure no mixing of observation & inpatient services in one encounter
; SRV=treating specialty pointer being assessed; IEN=DA - entry in file 405
NEW ADM,PAT,SERVICE
S ADM=$$GET1^DIQ(405,IEN,.14,"I") ;admission IEN
S PAT=$$GET1^DIQ(405,IEN,.03,"I") ;patient IEN
I $$ADMTXN(ADM,PAT)=IEN,$P($$LASTTXN(ADM,PAT),U)=IEN Q 1 ;okay if this is admission service entry and no other exists
I $$ADMTXN(ADM,PAT)=IEN,$P($$LASTTXN(ADM,PAT),U)=0 Q 1 ;okay if this is admission service entry and no other exists
;
; find service with which to compare
I $$ADMTXN(ADM,PAT)=IEN S SERVICE=$$LASTSRVN(ADM,PAT) ;if admission, check most recent transfer service
E S SERVICE=$$ADMSRV(ADM,PAT) ;else, use name of admission service
;
I (SERVICE["OBSERVATION"),($$GET1^DIQ(45.7,SRV,.01)'["OBSERVATION") Q 0
I (SERVICE'["OBSERVATION"),($$GET1^DIQ(45.7,SRV,.01)["OBSERVATION") Q 0
Q 1
;
;IHS/OIT/LJF 08/31/2006 PATCH 1006 added new subroutine
DESC ;EP; called by executable help on Admission Source field in file 405
NEW BDGC,BDGN,BDGD,BDGL,BDGSTOP
S (BDGC,BDGL,BDGSTOP)=0
F S BDGC=$O(^AUTTASRC("C",BDGC)) Q:BDGC="" Q:BDGSTOP D
. S BDGN=0 F S BDGN=$O(^AUTTASRC("C",BDGC,BDGN)) Q:'BDGN Q:BDGSTOP D
. . W !!,BDGC,?4,$P(^AUTTASRC(BDGN,0),U) S BDGL=BDGL+1
. . S BDGD=0 F S BDGD=$O(^AUTTASRC(BDGN,1,BDGD)) Q:'BDGD Q:BDGSTOP D
. . . W !,?6,^AUTTASRC(BDGN,1,BDGD,0) S BDGL=BDGL+1
. . I BDGL>12 S BDGL=0 I '$$READ^BDGF("E") S BDGSTOP=1 Q
Q
BDGF1 ; IHS/ANMC/LJF - INPT DATA FUNCTION CALLS ; [ 09/23/2004 5:04 PM ]
+1 ;;5.3;PIMS;**1001,1004,1006**;MAY 28, 2004
+2 ;IHS/ITSC/WAR 09/23/2004 PATCH 1001 use attending provider in PCC if there
+3 ;IHS/OIT/LJF 07/15/2005 PATCH 1004 fixed inverse date code
+4 ; 09/09/2005 PATCH 1004 added SRVCHK subroutine
+5 ; 08/31/2006 PATCH 1006 added DESC subroutine
+6 ;
+7 ; PAT=PAT of patient
+8 ; ADM=admission ien, also called corresponding admission (CA)
+9 ;
VISIT(PAT,DATE) ;PEP; return H or O visit ien for patient and admit date
+1 NEW RVDT,V,X,FOUND
+2 SET RVDT=9999999-$PIECE(DATE,".")_"."_$PIECE(DATE,".",2)
+3 SET FOUND=0
+4 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",PAT,RVDT,V))
IF 'V
QUIT
IF FOUND
QUIT
Begin DoDot:1
+5 SET X=$$GET1^DIQ(9000010,V,.07,"I")
IF (X="H")!(X="O")
SET FOUND=V
End DoDot:1
+6 QUIT $GET(FOUND)
+7 ;
INPT1(PAT,DATE) ;PEP; returns admit date (external format) if inpt on DATE sent
+1 NEW ADM,DSCH
+2 SET ADM=$ORDER(^DGPM("ATID1",PAT,9999999-DATE))
IF ADM=""
QUIT ""
+3 ;S DSCH=$O(^DGPM("APTT3",PAT,9999999-ADM))
+4 ;IHS/OIT/LJF 7/15/2005 PATCH 1004
SET DSCH=$ORDER(^DGPM("APTT3",PAT,9999999.9999999-ADM))
+5 IF DSCH]""&(DSCH<DATE)
QUIT ""
+6 SET ADM=9999999.99999999-ADM
+7 QUIT $$NUMDATE^BDGF(ADM,1)
+8 ;
ADMTXN(ADM,PAT) ;PEP; -- returns treating specialty node ien for admission
+1 ;called by ADT ITEMS file
+2 NEW DATE
+3 SET DATE=+$GET(^DGPM(ADM,0))
IF 'DATE
QUIT 0
+4 QUIT +$ORDER(^DGPM("APTT6",PAT,DATE,0))
+5 ;
ADMPRV(ADM,PAT,TYPE,MODE) ;PEP; -- returns provider for admission based on type
+1 ; TYPE="ADM" for admitting, "PRM" for primary, "ATT" for attending
+2 ; MODE="" for external format or ="I" for internal format
+3 ;called by ADT ITEMS file
+4 NEW IEN,FIELD
+5 IF ('ADM)!('PAT)
QUIT ""
+6 SET IEN=$$ADMTXN(ADM,PAT)
IF 'IEN
QUIT ""
+7 SET FIELD=$SELECT(TYPE="ADM":9999999.02,TYPE="ATT":.19,1:.08)
+8 QUIT $$GET1^DIQ(405,IEN,FIELD,$GET(MODE))
+9 ;
ADMPRVS(ADM,PAT,TYPE,MODE) ;PEP; -- returns provider's service based on type
+1 ; TYPE="ADM" for admitting, "PRM" for primary, "ATT" for attending
+2 ; MODE="" for external format or ="I" for internal format
+3 QUIT $$GET1^DIQ(200,+$$ADMPRV(ADM,PAT,TYPE,"I"),29,$GET(MODE))
+4 ;
ADMSRV(ADM,PAT) ;PEP; -- returns admitting service name
+1 NEW IEN
+2 IF ('ADM)!('PAT)
QUIT ""
+3 SET IEN=$$ADMTXN(ADM,PAT)
IF 'IEN
QUIT ""
+4 QUIT $$GET1^DIQ(405,IEN,.09)
+5 ;
ADMSRVN(ADM,PAT) ;PEP; -- returns admitting service ien
+1 NEW IEN
+2 IF ('ADM)!('PAT)
QUIT ""
+3 SET IEN=$$ADMTXN(ADM,PAT)
IF 'IEN
QUIT ""
+4 QUIT $$GET1^DIQ(405,IEN,.09,"I")
+5 ;
ADMSRVC(ADM,PAT) ;PEP; returns admitting service abbrev & code
+1 ;called by ADT ITEMS file
+2 NEW IEN,X
+3 IF ('ADM)!('PAT)
QUIT ""
+4 SET IEN=$$ADMSRVN(ADM,PAT)
IF 'IEN
QUIT ""
+5 SET X=$$GET1^DIQ(45.7,IEN,99)
IF X=""
SET X="??"
+6 QUIT X_" "_$$GET1^DIQ(45.7,IEN,9999999.01)
+7 ;
ADMTYP(ADM) ;PEP; returns IHS admit type and code
+1 ;called by ADT ITEMS file
+2 NEW X
+3 IF '$GET(ADM)
QUIT "??"
+4 ;internal
SET X=$$GET1^DIQ(405,ADM,.04,"I")
IF 'X
QUIT "??"
+5 SET X=$$GET1^DIQ(405.1,X,9999999.1)
+6 QUIT X_" "_$$GET1^DIQ(405,ADM,.04)
+7 ;
WRDABRV(PAT) ;PEP; returns abbreviation of current ward
+1 IF $GET(^DPT(PAT,.1))=""
QUIT ""
+2 NEW X
SET X=^DPT(PAT,.1)
SET X=$ORDER(^DIC(42,"B",X,0))
IF 'X
QUIT ""
+3 QUIT $$GET1^DIQ(9009016.5,X,.02)
+4 ;
WRDABRV2(N) ;PEP; returns abbreviation of ward for movement N
+1 NEW X
+2 SET X=$$GET1^DIQ(405,N,.06,"I")
IF 'X
QUIT ""
+3 QUIT $$GET1^DIQ(9009016.5,X,.02)
+4 ;
CURPRV(PAT,LENGTH) ;PEP; returns current attending provider for patient
+1 ; LENGTH=amount of room to fit name, optional
+2 NEW Y
SET Y=$$GET1^DIQ(2,PAT,.1041)
+3 IF '$GET(LENGTH)
SET LENGTH=20
+4 QUIT $EXTRACT(Y,1,LENGTH)
+5 ;
CURDX(PAT) ;PEP; returns admitting dx for current inpatient
+1 NEW CA
+2 SET CA=$GET(^DPT(PAT,.105))
IF 'CA
QUIT "??"
+3 QUIT $$GET1^DIQ(405,CA,.1)
+4 ;
CURLOS(PAT,MODE) ;PEP; returns length of stay for current inpatient
+1 ; MODE=1 means return observation in hours
+2 NEW CA,SRV
+3 SET CA=$GET(^DPT(PAT,.105))
IF 'CA
QUIT "??"
+4 SET SRV=$$GET1^DIQ(2,PAT,.103)
+5 IF $GET(MODE)
IF SRV["OBSERVATION"
QUIT $$LOSHRS(CA,$$NOW^XLFDT,PAT)_" hrs"
+6 QUIT $$GET1^DIQ(405,CA,201)_" days"
+7 ;
LASTTXN(ADM,PAT) ;PEP; returns last treating specialty ien for admission
+1 ; also returns last service as second U piece
+2 NEW DSC,DATE,SRV,IEN
+3 IF ('ADM)!('PAT)
QUIT 0
+4 ;find discharge if there
SET DSC=$$GET1^DIQ(405,ADM,.17,"I")
+5 ; start at discharge date or beginning if still inpt
+6 SET DATE=$SELECT(DSC="":0,1:9999999.9999999-$GET(^DGPM(DSC,0)))
+7 ; find date of last treating specialty change
+8 SET DATE=$ORDER(^DGPM("ATS",PAT,ADM,DATE))
IF 'DATE
QUIT 0
+9 ; find treating specialty ien
+10 SET SRV=$ORDER(^DGPM("ATS",PAT,ADM,DATE,0))
IF 'SRV
QUIT 0
+11 ; find treating specialty change ien
+12 SET IEN=$ORDER(^DGPM("ATS",PAT,ADM,DATE,SRV,0))
IF 'IEN
QUIT 0
+13 QUIT IEN_U_SRV
+14 ;
LASTSRVN(ADM,PAT) ;PEP; returns last service name
+1 IF ('ADM)!('PAT)
QUIT ""
+2 NEW X
+3 SET X=$PIECE($$LASTTXN(ADM,PAT),U,2)
IF 'X
QUIT ""
+4 QUIT $$GET1^DIQ(45.7,X,.01)
+5 ;
LASTSRVC(ADM,PAT) ;PEP; returns last service abbreviation and its code
+1 ;called by ADT ITEMS file
+2 IF ('ADM)!('PAT)
QUIT ""
+3 NEW X
+4 SET X=$PIECE($$LASTTXN(ADM,PAT),U,2)
IF 'X
QUIT ""
+5 QUIT $$GET1^DIQ(45.7,X,99)_" "_$$GET1^DIQ(45.7,X,9999999.01)
+6 ;
LASTPRV(ADM,PAT,MODE) ;PEP; returns last attending provider based on type
+1 ; MODE="" for external format or ="I" for internal format
+2 ;called by ADT ITEMS file
+3 NEW LAST
+4 SET LAST=$$LASTTXN(ADM,PAT)
IF 'LAST
QUIT "??"
+5 ;
+6 ;IHS/ITSC/WAR 9/23/04 PATCH #1001 Added next 2 lines per LJF
+7 NEW VST,PCC
SET VST=$$GET1^DIQ(405,+ADM,.27,"I")
+8 IF VST
SET PCC=$$PRIMPROV^APCLV(VST,$SELECT($GET(MODE)="":"N",1:MODE))
IF PCC]""
QUIT PCC
+9 ;IHS/ITSC/WAR end of 9/23/04 mod
+10 ;
+11 QUIT $$GET1^DIQ(405,+LAST,.19,$GET(MODE))
+12 ;
LASTPRVC(ADM,PAT) ;PEP; returns IHS ADC code for last attending provider by type
+1 ;called by ADT ITEMS file
+2 QUIT $$GET1^DIQ(200,+$$LASTPRV(ADM,PAT,"I"),9999999.09)
+3 ;
LASTPRVS(ADM,PAT,MODE) ;PEP; returns last attending provider's service
+1 ; MODE="" for external format or ="I" for internal format
+2 QUIT $$GET1^DIQ(200,+$$LASTPRV(ADM,PAT,"I"),29,$GET(MODE))
+3 ;
PRIORTXN(DATE,CA,PAT) ;PEP; returns treating specialty ien prior to date sent
+1 ; assumes date includes time
+2 NEW LAST,FOUND
+3 IF ('DATE)!('PAT)
QUIT 0
+4 ;
+5 ; if date=admit date, use admit service ien
+6 IF DATE=+$GET(^DGPM(CA,0))
QUIT +$ORDER(^DGPM("APTT6",PAT,DATE,0))
+7 ;
+8 ; find last service change (not provider change only)
+9 SET LAST=DATE
SET FOUND=0
+10 FOR
SET LAST=$ORDER(^DGPM("APTT6",PAT,LAST),-1)
IF 'LAST
QUIT
IF FOUND
QUIT
Begin DoDot:1
+11 SET N=$ORDER(^DGPM("APTT6",PAT,LAST,0))
IF 'N
QUIT
+12 ;has service
IF $PIECE($GET(^DGPM(N,0)),U,9)]""
SET FOUND=LAST
End DoDot:1
+13 ;
+14 ;return admit service
IF 'FOUND
QUIT $$ADMTXN(CA,PAT)
+15 QUIT +$ORDER(^DGPM("APTT6",PAT,FOUND,0))
+16 ;
PRIORMVT(DATE,CA,PAT) ;PEP; returns last physical movement before DATE
+1 NEW LAST
+2 IF ('DATE)!('CA)!('PAT)
QUIT 0
+3 SET LAST=$ORDER(^DGPM("APCA",PAT,CA,DATE),-1)
IF 'LAST
QUIT CA
+4 QUIT +$ORDER(^DGPM("APCA",PAT,CA,LAST,0))
+5 ;
LOSHRS(CA,DATE,PAT) ;PEP; returns length of stay in hours
+1 QUIT $JUSTIFY($$FMDIFF^XLFDT(DATE,+$GET(^DGPM(CA,0)),2)/3600,0,0)
+2 ;
READM(ADM,PAT,LIMIT) ;PEP; returns 1 if patient readmitted within parameter limit
+1 ; LIMIT is optional, if not sent will use site parameter
+2 ; returns LAST discharge date if within limits
+3 NEW ADMDT,LAST,DIFF
+4 ;new admit date
SET ADMDT=$$GET1^DIQ(405,ADM,.01,"I")
+5 ;bad entry
IF 'ADMDT
QUIT 0
+6 ;last discharge
SET LAST=$ORDER(^DGPM("APTT3",PAT,ADMDT),-1)
+7 ;1st admission
IF 'LAST
QUIT 0
+8 ;# of days diff
SET DIFF=$$FMDIFF^XLFDT(ADMDT,LAST)
+9 ;
+10 ; if limit was sent
+11 IF $GET(LIMIT)'=""
IF DIFF>LIMIT
QUIT 0
+12 ;
+13 ; if using site parameter
+14 IF $GET(LIMIT)=""
IF DIFF>$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),105)
QUIT 0
+15 ;
+16 QUIT 1_U_LAST
+17 ;
DSADM(ADM,PAT) ;PEP; returns 1 if patient admitted after day surgery w/in limit
+1 NEW ADMDT,LAST,DIFF
+2 ;new admit date
SET ADMDT=$$GET1^DIQ(405,ADM,.01,"I")
+3 ;last day surgery
SET LAST=$$LASTDS^BDGDSA(ADMDT,PAT)
+4 ;1st admission
IF 'LAST
QUIT 0
+5 ;# of days diff
SET DIFF=$$FMDIFF^XLFDT(ADMDT,LAST)
+6 IF DIFF>$$GET1^DIQ(9009020.1,+$$DIV^BDGPAR(DUZ(2)),107)
QUIT 0
+7 QUIT 1_U_LAST
+8 ;
LASTADM(PAT) ; Returns ien for patient's most recent admission
+1 NEW Y
+2 SET Y=$ORDER(^DGPM("ATID1",PAT,0))
IF 'Y
QUIT 0
+3 QUIT +$ORDER(^DGPM("ATID1",PAT,Y,0))
+4 ;
OPTOUT(PAT) ;EP; returns 1 if patient asked to opt-out of directory for current admission
+1 NEW X
+2 ;get admission ien
SET X=$$GET1^DIQ(2,PAT,.105,"I")
IF 'X
QUIT 0
+3 ;directory exclusion field
QUIT +$$GET1^DIQ(405,X,41,"I")
+4 ;
+5 ;IHS/OIT/LJF 09/09/2005 PATCH 1004 added new subroutine
SRVCHK(SRV,IEN) ;EP; called by 405 DD on field .09
+1 ; Make sure no mixing of observation & inpatient services in one encounter
+2 ; SRV=treating specialty pointer being assessed; IEN=DA - entry in file 405
+3 NEW ADM,PAT,SERVICE
+4 ;admission IEN
SET ADM=$$GET1^DIQ(405,IEN,.14,"I")
+5 ;patient IEN
SET PAT=$$GET1^DIQ(405,IEN,.03,"I")
+6 ;okay if this is admission service entry and no other exists
IF $$ADMTXN(ADM,PAT)=IEN
IF $PIECE($$LASTTXN(ADM,PAT),U)=IEN
QUIT 1
+7 ;okay if this is admission service entry and no other exists
IF $$ADMTXN(ADM,PAT)=IEN
IF $PIECE($$LASTTXN(ADM,PAT),U)=0
QUIT 1
+8 ;
+9 ; find service with which to compare
+10 ;if admission, check most recent transfer service
IF $$ADMTXN(ADM,PAT)=IEN
SET SERVICE=$$LASTSRVN(ADM,PAT)
+11 ;else, use name of admission service
IF '$TEST
SET SERVICE=$$ADMSRV(ADM,PAT)
+12 ;
+13 IF (SERVICE["OBSERVATION")
IF ($$GET1^DIQ(45.7,SRV,.01)'["OBSERVATION")
QUIT 0
+14 IF (SERVICE'["OBSERVATION")
IF ($$GET1^DIQ(45.7,SRV,.01)["OBSERVATION")
QUIT 0
+15 QUIT 1
+16 ;
+17 ;IHS/OIT/LJF 08/31/2006 PATCH 1006 added new subroutine
DESC ;EP; called by executable help on Admission Source field in file 405
+1 NEW BDGC,BDGN,BDGD,BDGL,BDGSTOP
+2 SET (BDGC,BDGL,BDGSTOP)=0
+3 FOR
SET BDGC=$ORDER(^AUTTASRC("C",BDGC))
IF BDGC=""
QUIT
IF BDGSTOP
QUIT
Begin DoDot:1
+4 SET BDGN=0
FOR
SET BDGN=$ORDER(^AUTTASRC("C",BDGC,BDGN))
IF 'BDGN
QUIT
IF BDGSTOP
QUIT
Begin DoDot:2
+5 WRITE !!,BDGC,?4,$PIECE(^AUTTASRC(BDGN,0),U)
SET BDGL=BDGL+1
+6 SET BDGD=0
FOR
SET BDGD=$ORDER(^AUTTASRC(BDGN,1,BDGD))
IF 'BDGD
QUIT
IF BDGSTOP
QUIT
Begin DoDot:3
+7 WRITE !,?6,^AUTTASRC(BDGN,1,BDGD,0)
SET BDGL=BDGL+1
End DoDot:3
+8 IF BDGL>12
SET BDGL=0
IF '$$READ^BDGF("E")
SET BDGSTOP=1
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
