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

AMERUTIL.m

Go to the documentation of this file. 
  1. AMERUTIL ;GDIT/HS/BEE - AMER UTILITY CALLS ; 07 Oct 2013  11:33 AM
  1.  ;;3.0;ER VISIT SYSTEM;**6,7,8**;MAR 03, 2009;Build 23
  1.  ;
  1.  Q
  1.  ;
  1. POV(AUPNPAT,AMERPCC,AMERPOV) ;EP - Return a list of POV entries for a visit
  1.  ;
  1.  ;Pass in DFN or VIEN, plus array to return information in
  1.  ;
  1.  ;Returns list of POVs in the following format:
  1.  ;AMERPOV(CNT)=[1]^[2]^[3]^[4]^[5]
  1.  ;[1] - ICD code
  1.  ;[2] - P-Primary, S-Secondary
  1.  ;[3] - Provider Narrative
  1.  ;[4] - IEN Pointer to file 80
  1.  ;[5] - ICD Description Value
  1.  ;[6] - V POV IEN
  1.  ;[7] - Injury (Yes/No)
  1.  ;
  1.  ;Function returns: [1] # of POV entries on file in piece 1 ^[2] Primary POV entered
  1.  ;
  1.  ;Quit if no DFN or visit IEN passed in
  1.  I $G(AUPNPAT)="",$G(AMERPCC)="" Q "0"
  1.  ;
  1.  ;If Visit IEN is blank retrieve from ER ADMISSION file
  1.  S:$G(AMERPCC)="" AMERPCC=$$GET1^DIQ(9009081,AUPNPAT,1.1,"I")
  1.  I AMERPCC="" Q "0"
  1.  ;
  1.  ;Reset output array
  1.  K AMERPOV
  1.  ;
  1.  NEW IEN,CNT,PRM
  1.  ;
  1.  ;Loop through the POVs for the visit
  1.  S (CNT,IEN,PRM)=0 F  S IEN=$O(^AUPNVPOV("AD",AMERPCC,IEN)) Q:'IEN  D
  1.  . NEW ICDIEN,VDATE,PS,ICDINFO,ICD,ICDDESC,PNAR,ICDV,INJ
  1.  . ;
  1.  . ;Get the narrative
  1.  . S PNAR=$$GET1^DIQ(9000010.07,IEN,.04,"E")
  1.  . ;
  1.  . ;Get the ICD Information
  1.  . S VDATE=$$FMTDATE($$GET1^DIQ(9000010,AMERPCC,.01,"I"))
  1.  . S ICDIEN=+$$GET1^DIQ(9000010.07,IEN,.01,"I")
  1.  . I $$AICD() S ICDINFO=$$ICDDX^ICDEX(ICDIEN,VDATE)
  1.  . E  S ICDINFO=$$ICDDX^ICDCODE(ICDIEN,VDATE)
  1.  . S ICD=$P(ICDINFO,U,2) Q:ICD=""
  1.  . ;
  1.  . ;Get the description
  1.  . S ICDDESC=$P(ICDINFO,U,4)
  1.  . ;
  1.  . ;Get primary/secondary
  1.  . S PS=$$GET1^DIQ(9000010.07,IEN_",",.12,"I")
  1.  . S:PS="" PS="S"
  1.  . ;AMER*3.0*7;Track if more than one Primary
  1.  . ;S:PS="P" PRM=1
  1.  . S:PS="P" PRM=PRM+1
  1.  . ;
  1.  . ;Get whether an injury - Flag if injury date or cause of injury
  1.  . S INJ="No"
  1.  . I $$GET1^DIQ(9000010.07,IEN_",",.13,"I") S INJ="Yes"
  1.  . E  I $$GET1^DIQ(9000010.07,IEN_",",.09,"I") S INJ="Yes"
  1.  . ;
  1.  . ;Set return entry
  1.  . S CNT=CNT+1
  1.  . S AMERPOV(CNT)=ICD_U_PS_U_PNAR_U_ICDIEN_U_ICDDESC_U_IEN_U_INJ
  1.  ;
  1.  Q CNT_U_PRM
  1.  ;
  1. AICD()   ;EP - Return 1 if AICD 4.0
  1.  Q $S($$VERSION^XPDUTL("AICD")="4.0":1,1:0)
  1.  ;
  1. FMTDATE(X,TM) ;EP - Return formated date - Taken from BGOUTL
  1.  Q:'X ""
  1.  N M,D,V
  1.  S M=$E(X,4,5),D=$E(X,6,7),V=$E(X,1,3)+1700
  1.  S:M&D V=D_"/"_V
  1.  S:M V=M_"/"_V
  1.  I $G(TM) D
  1.  .S X=X#1
  1.  .Q:'X
  1.  .S X=$TR($J(X*10000\1,4),0)
  1.  .S V=V_" "_$E(X,1,2)_":"_$E(X,3,4)
  1.  Q V
  1.  ;
  1. S(X) ;EP - Screen formatting - Based on AGVDF
  1.  NEW AMERM1,AMERMVDF
  1.  S AMERM1("X")=$X
  1.  S AMERM1("LN")=$T(@X),AMERM1(1)=$P(AMERM1("LN"),";;",2),AMERM1(2)=$P(AMERM1("LN"),";;",3),AMERM1(3)=$P(AMERM1("LN"),";;",4)
  1.  S AMERMVDF(+IOST(0),X)=$P($G(^%ZIS(2,+IOST(0),AMERM1(1))),"^",AMERM1(2),AMERM1(3))
  1.  I AMERMVDF(+IOST(0),X)="" S AMERMVDF(+IOST(0),X)="*0"
  1.  W @AMERMVDF(+IOST(0),X)
  1.  S $X=AMERM1("X")
  1.  S X=""
  1.  Q X
  1.  ;
  1. LEX(SEARCH,COUNT,FILTER,DATE,GENDER,RET) ;EP - Perform Lexicon Lookup
  1.  ;
  1.  ; SEARCH - The string to search on (Required)
  1.  ; COUNT  - The number of records to return (Optional) - Default 999
  1.  ; FILTER - 0 - Regular Search - Filter out Cause of Injury Codes (Default)
  1.  ;          1 - Cause of Injury Search - Return only Cause of Injury Codes
  1.  ;          2 - Full Search - Return all results - no filtering
  1.  ;   DATE - The date to search on (default to today)
  1.  ; GENDER - The patient gender (M/F/U) (Optional)
  1.  ;    RET - Return array
  1.  ;
  1.  ;Input checks
  1.  I $G(SEARCH)="" Q
  1.  S COUNT=$G(COUNT) S:'+COUNT COUNT=999
  1.  S FILTER=$G(FILTER) S:FILTER="" FILTER=0
  1.  S DATE=$G(DATE) S:DATE="" DATE=DT
  1.  S GENDER=$G(GENDER)
  1.  ;
  1.  NEW ICD10,CSET,DIC,AUPNSEX,LEX,DELIMITER,DPLIST,TOTREC
  1.  ;
  1.  K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
  1.  ;
  1.  ;Set gender variable used in filtering call
  1.  S:($G(GENDER)]"") AUPNSEX=GENDER
  1.  ;
  1.  ;Determine if ICD-10 has been implemented
  1.  S ICD10=0 I $$VERSION^XPDUTL("AICD")>3.51,$$IMP^ICDEXA(30)'>DATE S ICD10=1
  1.  S CSET=$S(ICD10=0:"ICD",1:"10D")
  1.  ;
  1.  D CONFIG^LEXSET(CSET,CSET,DATE)
  1.  ;S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
  1.  ;
  1.  ;Choose the filter
  1.  S DIC("S")="I $$FILTER^AMERUTIL(+Y,LEXVDT,$G(ICD10),$G(FILTER))"
  1.  ;
  1.  ;Perform search
  1.  D LOOK^LEXA(SEARCH,$G(CSET),$G(COUNT),$G(CSET),$G(DATE))
  1.  ;
  1.  ;Determine the delimiter
  1.  S DELIMITER=$S(ICD10=0:"ICD-9-CM ",1:"ICD-10-CM ")
  1.  ;
  1.  S TOTREC=0,LEX="0" F  S LEX=$O(LEX("LIST",LEX)) Q:LEX=""  D
  1.  . I '+LEX Q
  1.  . NEW CODE,LIEN,DIEN,DESC
  1.  . ;
  1.  . ;Get the code
  1.  . S CODE=$P($P(LEX("LIST",LEX),DELIMITER,2),")")
  1.  . ;
  1.  . ;Look for code in file 80
  1.  . I $$AICD() S ICD=$$ICDDX^ICDEX(CODE)
  1.  . E  S ICD=$$ICDDX^ICDCODE(CODE)
  1.  . ;
  1.  . ;If cannot find, tack on a period
  1.  . I $P(ICD,U)="-1",CODE'["." D
  1.  .. S CODE=CODE_"."
  1.  .. I $$AICD() S ICD=$$ICDDX^ICDEX(CODE)
  1.  .. E  S ICD=$$ICDDX^ICDCODE(CODE)
  1.  . ;
  1.  . ;Filter out duplicates
  1.  . I $D(DPLIST(CODE)) Q
  1.  . ;
  1.  . ;Quit if code not found
  1.  . I $P(ICD,U)="-1" Q
  1.  . ;
  1.  . ;Create entry to return
  1.  . S DIEN=$P(ICD,U) Q:DIEN=""
  1.  . S CODE=$P(ICD,U,2)
  1.  . S DESC=$P(ICD,U,4)
  1.  . S TOTREC=TOTREC+1,RET(TOTREC)=DIEN_U_CODE_U_DESC
  1.  . S DPLIST(CODE)=""
  1.  Q
  1.  ;
  1.  ;Filter on Cause of Injury
  1. FILTER(ALEX,ALEXVDT,ICD10,FILTER) ;Filtering for Lexicon lookup
  1.  ;
  1.  ;Input parameters
  1.  ;          ALEX - IEN of file 757.01
  1.  ;       ALEXVDT - Date to use for screening by codes
  1.  ;         ICD10 - 1 - ICD10, 0 - ICD9
  1.  ;        FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes
  1.  ;
  1.  NEW RETURN,APCDDATE
  1.  ;
  1.  ;Default to return
  1.  S RETURN=1
  1.  ;
  1.  ;For FILTER equal 2 - Return all
  1.  I $G(FILTER)=2 Q RETURN
  1.  ;
  1.  ;ICD9 - Filter 0
  1.  I FILTER=0,ICD10=0 D  Q RETURN
  1.  . N ALEXICD
  1.  . S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
  1.  . S ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT) I ALEX="" S RETURN="" Q
  1.  . S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
  1.  . I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
  1.  . S APCDDATE=ALEXVDT
  1.  . I '$$CHK^AUPNSICD($P(ALEXICD,U,1)) S RETURN="" Q
  1.  ;
  1.  ;ICD10 - Filter 0
  1.  I FILTER=0,ICD10=1 D  Q RETURN
  1.  . N ALEXICD
  1.  . S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") I ALEX="" S RETURN="" Q
  1.  . S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
  1.  . I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
  1.  . S APCDDATE=ALEXVDT
  1.  . I '$$CHK^AUPNSICD($P(ALEXICD,U,1)) S RETURN="" Q
  1.  ;
  1.  ;Both ICD9/ICD10 - Filter 1
  1.  I FILTER=1 D  Q RETURN
  1.  . N ALEXICD,ALEVXDT,%
  1.  . S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,$S(ICD10=1:"10D",1:"ICD")) I ALEX="" S RETURN="" Q
  1.  . S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
  1.  . I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
  1.  . I '$$CHK^AMERUTIL($P(ALEXICD,U,1),ICD10,ALEXVDT) S RETURN="" Q
  1.  ;
  1.  Q
  1.  ;
  1. CHK(Y,ICD10,ALEXVDT)   ;EP - SCREEN NON CAUSE OF INJURY AND INACTIVE CODES
  1.  NEW A,I,%
  1.  I $G(DUZ("AG"))'="I" Q 1
  1.  S:ALEXVDT="" ALEXVDT=DT
  1.  S I=$S($G(ICD10)=0:1,1:30)
  1.  S %=$$ICDDX^AUPNVUTL(Y,ALEXVDT,"I") I 1
  1.  I $P(%,U,20)]"",$P(%,U,20)'=I Q 0   ;not correct coding system
  1.  S I="CHKDX"_I
  1.  G @I
  1.  ;
  1. CHKDX1   ;CODING SYSTEM 1 - ICD9
  1.  ;
  1.  ;Only return E codes
  1.  I $E($P(%,U,2),1)'="E" Q 0
  1.  ;
  1.  ;Skip inactive codes
  1.  I '$P(%,U,10) Q 0  ;STATUS IS INACTIVE
  1.  ;
  1.  ;If 'USE WITH SEX' field has a value check that value against AUPNSEX
  1.  I '$D(AUPNSEX) Q 1
  1.  I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
  1.  Q 1
  1.  ;
  1. CHKDX30  ;coding system 30 - ICD10
  1.  NEW RET
  1.  S RET=0
  1.  I $E($P(%,U,2),1)="V" S RET=1
  1.  I 'RET,$E($P(%,U,2),1)="W" S RET=1
  1.  I 'RET,$E($P(%,U,2),1)="X" S RET=1
  1.  I 'RET,$E($P(%,U,2),1)="Y" D
  1.  . NEW EXC
  1.  . S EXC=$E($P(%,U,2),1,3)
  1.  . ;
  1.  . ;Handle exceptions to the list
  1.  . I EXC'="Y92",EXC'="Y93" S RET=1
  1.  . S RET=0
  1.  ;
  1.  I '$P(%,U,10) S RET=0  ;STATUS IS INACTIVE
  1.  ;
  1.  ;If 'USE WITH SEX' field has a value check that value against AUPNSEX
  1.  I '$D(AUPNSEX) Q RET
  1.  I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX S RET=0
  1.  Q RET
  1.  ;
  1.  ;Locations of screen handling options for device
  1. HIN ;;7;;1;;1;;HI INTENSITY ON
  1. HIF ;;7;;2;;2;;HI INTENSITY OFF
  1. RVN ;;5;;4;;4;;REVERSE VIDEO ON
  1. RVF ;;5;;5;;5;;REVERSE VIDEO OFF
  1. ULN ;;6;;4;;4;;UNDERLINE ON
  1. ULF ;;6;;5;;5;;UNDERLINE OFF
  1. DTP ;;17;;1;;1;;DOUBLE HIGH TOP HALF
  1. DTB ;;17;;2;;2;;DOUBLE HIGH BOTTOM HALF
  1. BLN ;;5;;8;;8;;BLINK ON
  1. BLF ;;5;;9;;9;;BLINK OFF
  1. IOF ;;1;;2;;2;;FORM FEED/CLEAR SCREEN
  1. 10  ;;5;;1;;1;;TEN PITCH
  1. 12  ;;5;;2;;2;;TWELVE PITCH
  1. 16  ;;12.1;;1;;250;;SIXTEEN PITCH