Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDGF1

BDGF1.m

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