BEDDPOV ;GDIT/HS/BEE-BEDD Utility Routine 4 ; 08 Nov 2011 12:00 PM
;;2.0;BEDD DASHBOARD;;Jun 04, 2014;Build 13
;
Q
;
DXLKP(VALUE,APCDD,SEX,FILTER) ;EP - Lookup to File 80 (DX)
;
;Input parameters
; VALUE - The text string to look up
; APCDD - The date to search on
; SEX - The patient sex (optional)
; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes (Default 0)
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDPOV D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
NEW I,BEDDLEX,LEX
;
;Make sure needed values are defined
S X="S:$G(U)="""" U=""""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
S SEX=$G(SEX)
S:$G(FILTER)="" FILTER=0
;
;Reset scratch global
K ^TMP("BEDDDX",$J)
;
;AICD and Lexicon ICD-10 have been installed. Use them for lookups
D LEX(VALUE,APCDD,SEX,.BEDDLEX,FILTER)
;
;Place returned information in scratch global
S I="" F S I=$O(BEDDLEX(I)) Q:I="" S ^TMP("BEDDDX",$J,I)=BEDDLEX(I)
;
Q
;
LEX(BEDDTXT,APCDD,SEX,BEDDLEX,FILTER) ;EP - Perform Lexicon lookup
;
;This call was adapted from APCDAPOV
;Input parameters
; BEDDTXT - The text string to look up
; APCDD - The date to search on
; SEX - The patient sex
; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes (Default 0)
;
;Return informaton
; BEDDLEX - Array of matches
; Format: BEDDLEX("LIST",#)=IEN^CODE^CODE DESCRIPTION
;
NEW APCDIMP,DIC,I,ICDV,LEX,X,RET
;
;Quit if no search string
I $G(BEDDTXT)="" Q
;
;Convert text to uppercase
S BEDDTXT=$$UPPER^BEDDUTID(BEDDTXT)
;
;Make sure initial variables are set
S:$G(U)="" U="^"
S:$G(DT)="" DT=$$DT^XLFDT
S:$G(APCDD)="" APCDD=DT
S:$G(FILTER)="" FILTER=0
;
;Retrieve the codeset in place
S APCDIMP=$$IMP^AUPNSICD(APCDD)
;
;Handle uncoded diagnosis entry
;
;Look up .9999 code (or switch to ZZZ.999 if ICD-10)
I BEDDTXT=".9999",FILTER'=1 D G XITL
. NEW %
. S %=$$ICDDX^AUPNVUTL($S(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
. S BEDDLEX(1)=$P(%,U,1,2)_U_$P(%,U,4)
;
;Look for ICD-10 Uncoded diagnosis code
I APCDIMP=30,((BEDDTXT="ZZZ.999")!($E(BEDDTXT,1,4)="ZZZ.")),FILTER'=1 D G XITL
. NEW %
. S %=$$ICDDX^AUPNVUTL($S(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
. S BEDDLEX(1)=$P(%,U,1,2)_U_$P(%,U,4)
;
;Look up Uncoded term
I (($E(BEDDTXT,1,7)="UNCODED")!(BEDDTXT["UNCODED D")),FILTER'=1 D G XITL
. NEW %
. S %=$$ICDDX^AUPNVUTL($S(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
. S BEDDLEX(1)=$P(%,U,1,2)_U_$P(%,U,4)
;
;Not an uncoded diagnosis, call the Lexicon
D LEX^AMERUTIL(BEDDTXT,100,FILTER,$P(APCDD,"."),SEX,.RET)
;
;I APCDIMP=1 D ICD9(BEDDTXT,$P(APCDD,"."),.LEX)
;I APCDIMP=30 D ICD10(BEDDTXT,$P(APCDD,"."),.LEX)
;
;Loop through results and format
S I=0 F S I=$O(RET(I)) Q:I="" D
. NEW ND,IEN,CODE,DESC
. S ND=$G(RET(I))
. S IEN=$P(ND,U)
. S CODE=$P(ND,U,2)
. S DESC=$P(ND,U,3)
. ;S DESC=$P(ND,U,2)
. ;S CODE=$P($P(DESC,"ICD-9-CM ",2),")")
. ;S DESC=$E($P(DESC," (ICD-9-CM"),1,159)
. S BEDDLEX(I)=IEN_U_CODE_U_DESC
. K RET(I)
;
XITL Q
;
ICD9(XTEXT,APCDDATE,LEX) ;Perform Lexicon ICD9 lookup
Q
;
ICD10(XTEXT,APCDDATE,LEX) ;Perform Lexicon ICD10 lookup
;
NEW DIC
K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
D CONFIG^LEXSET("10D","10D",APCDDATE)
S DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
D LOOK^LEXA(XTEXT,"10D",10,"10D",APCDDATE)
Q
;
XIT K Y,X,DO,D,DD,DIPGM,APCDTPCC
Q
;
ICD(ICDIEN,VDT) ;Return ICD information
;
;Input:
; ICDIEN - Pointer to file 80
; VDT - Date to search on
;
;Output:
; Standard AICD ICD data string return
;
NEW ICDINFO,X
;
;Make sure needed values are defined
S X="S:$G(U)="""" U=""""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
S:$G(VDT)="" VDT=DT
I $$AICD^AMERUTIL() S ICDINFO=$$ICDDX^ICDEX(ICDIEN,VDT)
E S ICDINFO=$$ICDDX^ICDCODE(ICDIEN,VDT)
;
Q ICDINFO
;
ERR ;EP - Capture the error
D ^%ZTER
Q
;
LIST(VIEN,DUZ,DXLIST) ;EP - Return list of V POV entries on file for visit
;
;Input variables
; VIEN - Visit IEN
; DUZ - User IEN
;
;Output array
; DXLIST - DXLIST(#)= [1] V POV IEN [2] Code [3] Code Description [4] P/S [5] Prov Narrative [6] Injury (Yes/No)
;
;Verify visit
I $G(VIEN)="" Q
;
NEW AMERPOV,POV,STS
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" G XSAVE
D DUZ^XUP(DUZ)
;
;Retrieve V POV entries
S STS=$$POV^AMERUTIL("",VIEN,.AMERPOV)
;
;Format for BEDD
S POV="" F S POV=$O(AMERPOV(POV)) Q:POV="" D
. NEW VPOVIEN,ICDIEN,CODE,DESC,PS,NARR,N
. S N=AMERPOV(POV)
. S DXLIST(POV)=$P(N,U,6)_U_$P(N,U)_U_$P(N,U,5)_U_$P(N,U,2)_U_$P(N,U,3)_U_$P(N,U,7)
;
Q
;
GETDX(VPOV) ;EP - Retrieve V POV information for a particular entry
;
NEW RESULT,CODE,PS,NARR,DESC,VIEN,VDATE,ICDINFO,CODEIEN,INJ
;
;Check for VPOV entry
I $G(VPOV)="" Q ""
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Get the visit IEN and visit date
S VIEN=$$GET1^DIQ(9000010.07,VPOV_",",".03","I") Q:VIEN="" ""
S VDATE=$P($$GET1^DIQ(9000010,VIEN_",",.01,"I"),".")
;
S RESULT=""
;
S CODEIEN=$$GET1^DIQ(9000010.07,VPOV_",",".01","I") Q:CODEIEN="" ;Code IEN
S CODE=$$GET1^DIQ(9000010.07,VPOV_",",".01","E") Q:CODE="" "" ;Code
S PS=$$GET1^DIQ(9000010.07,VPOV_",",".12","I") ;Primary/Secondary
S NARR=$$GET1^DIQ(9000010.07,VPOV_",",".04","E") Q:NARR="" ;Provider Narrative
;
;Get whether an injury - Flag if injury date or cause of injury
S INJ="No"
I $$GET1^DIQ(9000010.07,VPOV_",",.13,"I") S INJ="Yes"
E I $$GET1^DIQ(9000010.07,VPOV_",",.09,"I") S INJ="Yes"
;
;Code Description
I $$AICD^AMERUTIL() S ICDINFO=$$ICDDX^ICDEX(CODEIEN,VDATE)
E S ICDINFO=$$ICDDX^ICDCODE(CODEIEN,VDATE)
S DESC=$P(ICDINFO,U,4) S:$E(DESC,1)="*" DESC=$E(DESC,2,9999)
;
;Return the results
S RESULT=VPOV_U_CODE_U_DESC_U_PS_U_NARR_U_CODEIEN_U_INJ
;
Q RESULT
;
DEL(VPOVIEN,DUZ) ;Delete a POV entry
;
NEW VPOVUPD,ERROR,AUPNVSIT
;
I $G(VPOVIEN)="" Q 0
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" G XSAVE
D DUZ^XUP(DUZ)
;
;Get the visit IEN
S AUPNVSIT=$$GET1^DIQ(9000010.07,VPOVIEN,".03","I")
;
S VPOVUPD(9000010.07,VPOVIEN_",",.01)="@"
D FILE^DIE("","VPOVUPD","ERROR")
;
;Flag that visit was updated
D MOD^AUPNVSIT
;
I $D(ERROR) Q 0
Q 1
;
SAVE(VPOVIEN,ICDIEN,PNARR,PS,CODE,INJ,VIEN,DUZ,DFN) ;Add/Update POV entry
;
NEW STS,IN,X,APCDALVR,APCDPAT,APCDLOOK,APCDVSIT,APCDDATE,APCDTYPE,APCDCAT,APCDLOC,APCDCLN,PROV
NEW APCDTDI,APCDTCD,APCDTPA,POVUPD,ERROR,ICD,AUPNVSIT,INJURY
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" G XSAVE
D DUZ^XUP(DUZ)
;
;Reset STS
S STS=0
;
;Get the provider narrative IEN
S PNARR=$$FNDNARR(PNARR)
;
;Get primary provider
S PROV=""
I $G(VIEN)>0 D
. NEW IEN
. ;
. ;Loop through the list and find the primary provider
. S IEN=0 F S IEN=$O(^AUPNVPRV("AD",VIEN,IEN)) Q:IEN="" D Q:+PROV
.. NEW PS
.. S PS=$$GET1^DIQ(9000010.06,IEN_",",.04,"I") Q:PS'="P"
.. ;
.. ;Get the primary provider
.. S PROV=$$GET1^DIQ(9000010.06,IEN_",",.01,"I")
. ;
. ;If there isn't one yet, use DUZ
. S:PROV="" PROV=$G(DUZ)
;
;Retrieve the Injury information
I $G(INJ)="YES" D
. NEW INJPL
. ;
. ;Retrieve injury information
. D INJURY^BEDDINJ(VIEN,.INJURY)
. S:$G(INJURY("INDAT"))]"" APCDTDI=$P(INJURY("INDAT"),".")
. S:$G(INJURY("ICIEN"))]"" APCDTCD=INJURY("ICIEN")
. S INJPL=""
. S:$G(INJURY("INSET"))]"" INJPL=INJURY("INSET")
. ;
. ;Injury place
. I INJPL]"" S INJPL=$$GET1^DIQ(9009083,INJPL_",",.01,"E")
. ;
. ;Valid PCC values
. ;A:HOME-INSIDE;B:HOME-OUTSIDE;C:FARM;D:SCHOOL;E:INDUSTRIAL PREMISES;F:RECREATIONAL AREA;
. ;G:STREET/HIGHWAY;H:PUBLIC BUILDING;I:RESIDENT INSTITUTION;J:HUNTING/FISHING;K:OTHER;L:UNKNOWN
. S APCDTPA="L"
. I INJPL["HIGHWAY" S APCDTPA="G"
. E I INJPL["HOME" S APCDTPA="A"
. E I INJPL["INDUSTRIAL" S APCDTPA="E"
. E I INJPL["MINE" S APCDTPA="K"
. E I INJPL["OTHER" S APCDTPA="K"
. E I INJPL["PUBLIC" S APCDTPA="H"
. E I INJPL["FARM" S APCDTPA="C"
. E I INJPL["RECREATION" S APCDTPA="F"
. E I INJPL["RESIDENT" S APCDTPA="I"
. E I INJPL["UNSPECIFIED" S APCDTPA="L"
. E I INJPL["SCHOOL" S APCDTPA="D"
. E I INJPL["HUNTING" S APCDTPA="J"
. E I INJPL["FISHING" S APCDTPA="J"
;
;Location
S APCDLOC=$$GET1^DIQ(9000010,VIEN_",",.06,"I")
;
;Process Adds
I +VPOVIEN=0 D
. ;
. NEW APCDALVR
. ;
. ;Set Patient
. S APCDALVR("APCDPAT")=DFN ;Patient DFN
. ;
. ;Define Visit IEN
. S APCDALVR("APCDVSIT")=VIEN ;Visit IEN
. ;
. ;Define External ICD code
. S APCDALVR("APCDTPOV")=CODE
. ;
. ;Location
. S APCDALVR("APCDLOC")=$S(APCDLOC'="":APCDLOC,1:DUZ(2))
. ;
. ;Determine which template to use
. S APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
. ;
. ;Make the add call
. D ^APCDALVR
. ;
. ;If success get V Pointer
. I '$D(APCDALVR("APCDAFLG")) S VPOVIEN=$G(APCDALVR("APCDADFN"))
. I $D(APCDALVR("APCDAFLG")) S STS=-1
;
;Now perform edits (add in extra fields for adds)
S POVUPD(9000010.07,+VPOVIEN_",",.12)=$S(PS="YES":"P",1:"S") ;Primary/Secondary
S POVUPD(9000010.07,+VPOVIEN_",",.04)=$S($G(PNARR)]"":PNARR,1:"@") ;Prov Narrative
S POVUPD(9000010.07,+VPOVIEN_",",.13)=$S($G(APCDTDI)]"":APCDTDI,1:"@") ;Date of Injury
S POVUPD(9000010.07,+VPOVIEN_",",.09)=$S($G(APCDTCD)]"":APCDTCD,1:"@") ;Cause of Injury
S POVUPD(9000010.07,+VPOVIEN_",",.11)=$S($G(APCDTPA)]"":APCDTPA,1:"@") ;Injury Setting
S POVUPD(9000010.07,+VPOVIEN_",",.01)=ICDIEN ;Code
D FILE^DIE("","POVUPD","ERROR")
;
;Flag Visit update
S AUPNVSIT=VIEN D MOD^AUPNVSIT
;
XSAVE Q STS
;
FNDNARR(NARR,CREATE) ;File narrative and return IEN
N IEN,FDA,TRC,RET
Q:'$L(NARR) ""
S IEN=0,TRC=$E(NARR,1,30),NARR=$E(NARR,1,160),CREATE=$G(CREATE,1)
F S IEN=$O(^AUTNPOV("B",TRC,IEN)) Q:'IEN Q:$P($G(^AUTNPOV(IEN,0)),U)=NARR
Q:IEN!'CREATE IEN
S FDA(9999999.27,"+1,",.01)=NARR
S RET=$$UPDATE^BGOUTL(.FDA,"E",.IEN)
Q $S(RET:RET,1:IEN(1))
;
GETPOV(VIEN) ;Return POV information for visit
;
I $G(VIEN)="" Q 0
;
NEW POV,PRMCNT,DXCNT,CNT
;
;
;Make sure needed values are defined
S X="S:$G(U)="""" U=""""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Reset values
S (PRMCNT,DXCNT)=0
;
;Get POV information
D POV^AMERUTIL("",VIEN,.POV)
;
S CNT="" F S CNT=$O(POV(CNT)) Q:CNT="" D
. S DXCNT=DXCNT+1 ;Total Dx entries
. I $P(POV(CNT),"^",2)="P" S PRMCNT=PRMCNT+1 ;Total Primary Entries
;
Q DXCNT_"^"_PRMCNT
BEDDPOV ;GDIT/HS/BEE-BEDD Utility Routine 4 ; 08 Nov 2011 12:00 PM
+1 ;;2.0;BEDD DASHBOARD;;Jun 04, 2014;Build 13
+2 ;
+3 QUIT
+4 ;
DXLKP(VALUE,APCDD,SEX,FILTER) ;EP - Lookup to File 80 (DX)
+1 ;
+2 ;Input parameters
+3 ; VALUE - The text string to look up
+4 ; APCDD - The date to search on
+5 ; SEX - The patient sex (optional)
+6 ; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes (Default 0)
+7 ;
+8 ;Error Trapping
+9 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDPOV D UNWIND^%ZTER"
+10 ;
+11 NEW I,BEDDLEX,LEX
+12 ;
+13 ;Make sure needed values are defined
+14 SET X="S:$G(U)="""" U="""""
XECUTE X
+15 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+16 ;
+17 SET SEX=$GET(SEX)
+18 IF $GET(FILTER)=""
SET FILTER=0
+19 ;
+20 ;Reset scratch global
+21 KILL ^TMP("BEDDDX",$JOB)
+22 ;
+23 ;AICD and Lexicon ICD-10 have been installed. Use them for lookups
+24 DO LEX(VALUE,APCDD,SEX,.BEDDLEX,FILTER)
+25 ;
+26 ;Place returned information in scratch global
+27 SET I=""
FOR
SET I=$ORDER(BEDDLEX(I))
IF I=""
QUIT
SET ^TMP("BEDDDX",$JOB,I)=BEDDLEX(I)
+28 ;
+29 QUIT
+30 ;
LEX(BEDDTXT,APCDD,SEX,BEDDLEX,FILTER) ;EP - Perform Lexicon lookup
+1 ;
+2 ;This call was adapted from APCDAPOV
+3 ;Input parameters
+4 ; BEDDTXT - The text string to look up
+5 ; APCDD - The date to search on
+6 ; SEX - The patient sex
+7 ; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes (Default 0)
+8 ;
+9 ;Return informaton
+10 ; BEDDLEX - Array of matches
+11 ; Format: BEDDLEX("LIST",#)=IEN^CODE^CODE DESCRIPTION
+12 ;
+13 NEW APCDIMP,DIC,I,ICDV,LEX,X,RET
+14 ;
+15 ;Quit if no search string
+16 IF $GET(BEDDTXT)=""
QUIT
+17 ;
+18 ;Convert text to uppercase
+19 SET BEDDTXT=$$UPPER^BEDDUTID(BEDDTXT)
+20 ;
+21 ;Make sure initial variables are set
+22 IF $GET(U)=""
SET U="^"
+23 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+24 IF $GET(APCDD)=""
SET APCDD=DT
+25 IF $GET(FILTER)=""
SET FILTER=0
+26 ;
+27 ;Retrieve the codeset in place
+28 SET APCDIMP=$$IMP^AUPNSICD(APCDD)
+29 ;
+30 ;Handle uncoded diagnosis entry
+31 ;
+32 ;Look up .9999 code (or switch to ZZZ.999 if ICD-10)
+33 IF BEDDTXT=".9999"
IF FILTER'=1
Begin DoDot:1
+34 NEW %
+35 SET %=$$ICDDX^AUPNVUTL($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
+36 SET BEDDLEX(1)=$PIECE(%,U,1,2)_U_$PIECE(%,U,4)
End DoDot:1
GOTO XITL
+37 ;
+38 ;Look for ICD-10 Uncoded diagnosis code
+39 IF APCDIMP=30
IF ((BEDDTXT="ZZZ.999")!($EXTRACT(BEDDTXT,1,4)="ZZZ."))
IF FILTER'=1
Begin DoDot:1
+40 NEW %
+41 SET %=$$ICDDX^AUPNVUTL($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
+42 SET BEDDLEX(1)=$PIECE(%,U,1,2)_U_$PIECE(%,U,4)
End DoDot:1
GOTO XITL
+43 ;
+44 ;Look up Uncoded term
+45 IF (($EXTRACT(BEDDTXT,1,7)="UNCODED")!(BEDDTXT["UNCODED D"))
IF FILTER'=1
Begin DoDot:1
+46 NEW %
+47 SET %=$$ICDDX^AUPNVUTL($SELECT(APCDIMP=1:".9999",1:"ZZZ.999"),,"E")
+48 SET BEDDLEX(1)=$PIECE(%,U,1,2)_U_$PIECE(%,U,4)
End DoDot:1
GOTO XITL
+49 ;
+50 ;Not an uncoded diagnosis, call the Lexicon
+51 DO LEX^AMERUTIL(BEDDTXT,100,FILTER,$PIECE(APCDD,"."),SEX,.RET)
+52 ;
+53 ;I APCDIMP=1 D ICD9(BEDDTXT,$P(APCDD,"."),.LEX)
+54 ;I APCDIMP=30 D ICD10(BEDDTXT,$P(APCDD,"."),.LEX)
+55 ;
+56 ;Loop through results and format
+57 SET I=0
FOR
SET I=$ORDER(RET(I))
IF I=""
QUIT
Begin DoDot:1
+58 NEW ND,IEN,CODE,DESC
+59 SET ND=$GET(RET(I))
+60 SET IEN=$PIECE(ND,U)
+61 SET CODE=$PIECE(ND,U,2)
+62 SET DESC=$PIECE(ND,U,3)
+63 ;S DESC=$P(ND,U,2)
+64 ;S CODE=$P($P(DESC,"ICD-9-CM ",2),")")
+65 ;S DESC=$E($P(DESC," (ICD-9-CM"),1,159)
+66 SET BEDDLEX(I)=IEN_U_CODE_U_DESC
+67 KILL RET(I)
End DoDot:1
+68 ;
XITL QUIT
+1 ;
ICD9(XTEXT,APCDDATE,LEX) ;Perform Lexicon ICD9 lookup
+1 QUIT
+2 ;
ICD10(XTEXT,APCDDATE,LEX) ;Perform Lexicon ICD10 lookup
+1 ;
+2 NEW DIC
+3 KILL ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
+4 DO CONFIG^LEXSET("10D","10D",APCDDATE)
+5 SET DIC("S")="I $$ICDONE1^APCDAPOV(+Y,LEXVDT)"
+6 DO LOOK^LEXA(XTEXT,"10D",10,"10D",APCDDATE)
+7 QUIT
+8 ;
XIT KILL Y,X,DO,D,DD,DIPGM,APCDTPCC
+1 QUIT
+2 ;
ICD(ICDIEN,VDT) ;Return ICD information
+1 ;
+2 ;Input:
+3 ; ICDIEN - Pointer to file 80
+4 ; VDT - Date to search on
+5 ;
+6 ;Output:
+7 ; Standard AICD ICD data string return
+8 ;
+9 NEW ICDINFO,X
+10 ;
+11 ;Make sure needed values are defined
+12 SET X="S:$G(U)="""" U="""""
XECUTE X
+13 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+14 ;
+15 IF $GET(VDT)=""
SET VDT=DT
+16 IF $$AICD^AMERUTIL()
SET ICDINFO=$$ICDDX^ICDEX(ICDIEN,VDT)
+17 IF '$TEST
SET ICDINFO=$$ICDDX^ICDCODE(ICDIEN,VDT)
+18 ;
+19 QUIT ICDINFO
+20 ;
ERR ;EP - Capture the error
+1 DO ^%ZTER
+2 QUIT
+3 ;
LIST(VIEN,DUZ,DXLIST) ;EP - Return list of V POV entries on file for visit
+1 ;
+2 ;Input variables
+3 ; VIEN - Visit IEN
+4 ; DUZ - User IEN
+5 ;
+6 ;Output array
+7 ; DXLIST - DXLIST(#)= [1] V POV IEN [2] Code [3] Code Description [4] P/S [5] Prov Narrative [6] Injury (Yes/No)
+8 ;
+9 ;Verify visit
+10 IF $GET(VIEN)=""
QUIT
+11 ;
+12 NEW AMERPOV,POV,STS
+13 ;
+14 ;Make sure initial variables are set
+15 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+16 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+17 ;
+18 ;Define DUZ variable
+19 IF $GET(DUZ)=""
SET STS="Missing DUZ"
GOTO XSAVE
+20 DO DUZ^XUP(DUZ)
+21 ;
+22 ;Retrieve V POV entries
+23 SET STS=$$POV^AMERUTIL("",VIEN,.AMERPOV)
+24 ;
+25 ;Format for BEDD
+26 SET POV=""
FOR
SET POV=$ORDER(AMERPOV(POV))
IF POV=""
QUIT
Begin DoDot:1
+27 NEW VPOVIEN,ICDIEN,CODE,DESC,PS,NARR,N
+28 SET N=AMERPOV(POV)
+29 SET DXLIST(POV)=$PIECE(N,U,6)_U_$PIECE(N,U)_U_$PIECE(N,U,5)_U_$PIECE(N,U,2)_U_$PIECE(N,U,3)_U_$PIECE(N,U,7)
End DoDot:1
+30 ;
+31 QUIT
+32 ;
GETDX(VPOV) ;EP - Retrieve V POV information for a particular entry
+1 ;
+2 NEW RESULT,CODE,PS,NARR,DESC,VIEN,VDATE,ICDINFO,CODEIEN,INJ
+3 ;
+4 ;Check for VPOV entry
+5 IF $GET(VPOV)=""
QUIT ""
+6 ;
+7 ;Make sure initial variables are set
+8 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+9 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+10 ;
+11 ;Get the visit IEN and visit date
+12 SET VIEN=$$GET1^DIQ(9000010.07,VPOV_",",".03","I")
IF VIEN=""
QUIT ""
+13 SET VDATE=$PIECE($$GET1^DIQ(9000010,VIEN_",",.01,"I"),".")
+14 ;
+15 SET RESULT=""
+16 ;
+17 ;Code IEN
SET CODEIEN=$$GET1^DIQ(9000010.07,VPOV_",",".01","I")
IF CODEIEN=""
QUIT
+18 ;Code
SET CODE=$$GET1^DIQ(9000010.07,VPOV_",",".01","E")
IF CODE=""
QUIT ""
+19 ;Primary/Secondary
SET PS=$$GET1^DIQ(9000010.07,VPOV_",",".12","I")
+20 ;Provider Narrative
SET NARR=$$GET1^DIQ(9000010.07,VPOV_",",".04","E")
IF NARR=""
QUIT
+21 ;
+22 ;Get whether an injury - Flag if injury date or cause of injury
+23 SET INJ="No"
+24 IF $$GET1^DIQ(9000010.07,VPOV_",",.13,"I")
SET INJ="Yes"
+25 IF '$TEST
IF $$GET1^DIQ(9000010.07,VPOV_",",.09,"I")
SET INJ="Yes"
+26 ;
+27 ;Code Description
+28 IF $$AICD^AMERUTIL()
SET ICDINFO=$$ICDDX^ICDEX(CODEIEN,VDATE)
+29 IF '$TEST
SET ICDINFO=$$ICDDX^ICDCODE(CODEIEN,VDATE)
+30 SET DESC=$PIECE(ICDINFO,U,4)
IF $EXTRACT(DESC,1)="*"
SET DESC=$EXTRACT(DESC,2,9999)
+31 ;
+32 ;Return the results
+33 SET RESULT=VPOV_U_CODE_U_DESC_U_PS_U_NARR_U_CODEIEN_U_INJ
+34 ;
+35 QUIT RESULT
+36 ;
DEL(VPOVIEN,DUZ) ;Delete a POV entry
+1 ;
+2 NEW VPOVUPD,ERROR,AUPNVSIT
+3 ;
+4 IF $GET(VPOVIEN)=""
QUIT 0
+5 ;
+6 ;Make sure initial variables are set
+7 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+8 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+9 ;
+10 ;Define DUZ variable
+11 IF $GET(DUZ)=""
SET STS="Missing DUZ"
GOTO XSAVE
+12 DO DUZ^XUP(DUZ)
+13 ;
+14 ;Get the visit IEN
+15 SET AUPNVSIT=$$GET1^DIQ(9000010.07,VPOVIEN,".03","I")
+16 ;
+17 SET VPOVUPD(9000010.07,VPOVIEN_",",.01)="@"
+18 DO FILE^DIE("","VPOVUPD","ERROR")
+19 ;
+20 ;Flag that visit was updated
+21 DO MOD^AUPNVSIT
+22 ;
+23 IF $DATA(ERROR)
QUIT 0
+24 QUIT 1
+25 ;
SAVE(VPOVIEN,ICDIEN,PNARR,PS,CODE,INJ,VIEN,DUZ,DFN) ;Add/Update POV entry
+1 ;
+2 NEW STS,IN,X,APCDALVR,APCDPAT,APCDLOOK,APCDVSIT,APCDDATE,APCDTYPE,APCDCAT,APCDLOC,APCDCLN,PROV
+3 NEW APCDTDI,APCDTCD,APCDTPA,POVUPD,ERROR,ICD,AUPNVSIT,INJURY
+4 ;
+5 ;Make sure initial variables are set
+6 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+7 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+8 ;
+9 ;Define DUZ variable
+10 IF $GET(DUZ)=""
SET STS="Missing DUZ"
GOTO XSAVE
+11 DO DUZ^XUP(DUZ)
+12 ;
+13 ;Reset STS
+14 SET STS=0
+15 ;
+16 ;Get the provider narrative IEN
+17 SET PNARR=$$FNDNARR(PNARR)
+18 ;
+19 ;Get primary provider
+20 SET PROV=""
+21 IF $GET(VIEN)>0
Begin DoDot:1
+22 NEW IEN
+23 ;
+24 ;Loop through the list and find the primary provider
+25 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNVPRV("AD",VIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+26 NEW PS
+27 SET PS=$$GET1^DIQ(9000010.06,IEN_",",.04,"I")
IF PS'="P"
QUIT
+28 ;
+29 ;Get the primary provider
+30 SET PROV=$$GET1^DIQ(9000010.06,IEN_",",.01,"I")
End DoDot:2
IF +PROV
QUIT
+31 ;
+32 ;If there isn't one yet, use DUZ
+33 IF PROV=""
SET PROV=$GET(DUZ)
End DoDot:1
+34 ;
+35 ;Retrieve the Injury information
+36 IF $GET(INJ)="YES"
Begin DoDot:1
+37 NEW INJPL
+38 ;
+39 ;Retrieve injury information
+40 DO INJURY^BEDDINJ(VIEN,.INJURY)
+41 IF $GET(INJURY("INDAT"))]""
SET APCDTDI=$PIECE(INJURY("INDAT"),".")
+42 IF $GET(INJURY("ICIEN"))]""
SET APCDTCD=INJURY("ICIEN")
+43 SET INJPL=""
+44 IF $GET(INJURY("INSET"))]""
SET INJPL=INJURY("INSET")
+45 ;
+46 ;Injury place
+47 IF INJPL]""
SET INJPL=$$GET1^DIQ(9009083,INJPL_",",.01,"E")
+48 ;
+49 ;Valid PCC values
+50 ;A:HOME-INSIDE;B:HOME-OUTSIDE;C:FARM;D:SCHOOL;E:INDUSTRIAL PREMISES;F:RECREATIONAL AREA;
+51 ;G:STREET/HIGHWAY;H:PUBLIC BUILDING;I:RESIDENT INSTITUTION;J:HUNTING/FISHING;K:OTHER;L:UNKNOWN
+52 SET APCDTPA="L"
+53 IF INJPL["HIGHWAY"
SET APCDTPA="G"
+54 IF '$TEST
IF INJPL["HOME"
SET APCDTPA="A"
+55 IF '$TEST
IF INJPL["INDUSTRIAL"
SET APCDTPA="E"
+56 IF '$TEST
IF INJPL["MINE"
SET APCDTPA="K"
+57 IF '$TEST
IF INJPL["OTHER"
SET APCDTPA="K"
+58 IF '$TEST
IF INJPL["PUBLIC"
SET APCDTPA="H"
+59 IF '$TEST
IF INJPL["FARM"
SET APCDTPA="C"
+60 IF '$TEST
IF INJPL["RECREATION"
SET APCDTPA="F"
+61 IF '$TEST
IF INJPL["RESIDENT"
SET APCDTPA="I"
+62 IF '$TEST
IF INJPL["UNSPECIFIED"
SET APCDTPA="L"
+63 IF '$TEST
IF INJPL["SCHOOL"
SET APCDTPA="D"
+64 IF '$TEST
IF INJPL["HUNTING"
SET APCDTPA="J"
+65 IF '$TEST
IF INJPL["FISHING"
SET APCDTPA="J"
End DoDot:1
+66 ;
+67 ;Location
+68 SET APCDLOC=$$GET1^DIQ(9000010,VIEN_",",.06,"I")
+69 ;
+70 ;Process Adds
+71 IF +VPOVIEN=0
Begin DoDot:1
+72 ;
+73 NEW APCDALVR
+74 ;
+75 ;Set Patient
+76 ;Patient DFN
SET APCDALVR("APCDPAT")=DFN
+77 ;
+78 ;Define Visit IEN
+79 ;Visit IEN
SET APCDALVR("APCDVSIT")=VIEN
+80 ;
+81 ;Define External ICD code
+82 SET APCDALVR("APCDTPOV")=CODE
+83 ;
+84 ;Location
+85 SET APCDALVR("APCDLOC")=$SELECT(APCDLOC'="":APCDLOC,1:DUZ(2))
+86 ;
+87 ;Determine which template to use
+88 SET APCDALVR("APCDATMP")="[APCDALVR 9000010.07 (ADD)]"
+89 ;
+90 ;Make the add call
+91 DO ^APCDALVR
+92 ;
+93 ;If success get V Pointer
+94 IF '$DATA(APCDALVR("APCDAFLG"))
SET VPOVIEN=$GET(APCDALVR("APCDADFN"))
+95 IF $DATA(APCDALVR("APCDAFLG"))
SET STS=-1
End DoDot:1
+96 ;
+97 ;Now perform edits (add in extra fields for adds)
+98 ;Primary/Secondary
SET POVUPD(9000010.07,+VPOVIEN_",",.12)=$SELECT(PS="YES":"P",1:"S")
+99 ;Prov Narrative
SET POVUPD(9000010.07,+VPOVIEN_",",.04)=$SELECT($GET(PNARR)]"":PNARR,1:"@")
+100 ;Date of Injury
SET POVUPD(9000010.07,+VPOVIEN_",",.13)=$SELECT($GET(APCDTDI)]"":APCDTDI,1:"@")
+101 ;Cause of Injury
SET POVUPD(9000010.07,+VPOVIEN_",",.09)=$SELECT($GET(APCDTCD)]"":APCDTCD,1:"@")
+102 ;Injury Setting
SET POVUPD(9000010.07,+VPOVIEN_",",.11)=$SELECT($GET(APCDTPA)]"":APCDTPA,1:"@")
+103 ;Code
SET POVUPD(9000010.07,+VPOVIEN_",",.01)=ICDIEN
+104 DO FILE^DIE("","POVUPD","ERROR")
+105 ;
+106 ;Flag Visit update
+107 SET AUPNVSIT=VIEN
DO MOD^AUPNVSIT
+108 ;
XSAVE QUIT STS
+1 ;
FNDNARR(NARR,CREATE) ;File narrative and return IEN
+1 NEW IEN,FDA,TRC,RET
+2 IF '$LENGTH(NARR)
QUIT ""
+3 SET IEN=0
SET TRC=$EXTRACT(NARR,1,30)
SET NARR=$EXTRACT(NARR,1,160)
SET CREATE=$GET(CREATE,1)
+4 FOR
SET IEN=$ORDER(^AUTNPOV("B",TRC,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^AUTNPOV(IEN,0)),U)=NARR
QUIT
+5 IF IEN!'CREATE
QUIT IEN
+6 SET FDA(9999999.27,"+1,",.01)=NARR
+7 SET RET=$$UPDATE^BGOUTL(.FDA,"E",.IEN)
+8 QUIT $SELECT(RET:RET,1:IEN(1))
+9 ;
GETPOV(VIEN) ;Return POV information for visit
+1 ;
+2 IF $GET(VIEN)=""
QUIT 0
+3 ;
+4 NEW POV,PRMCNT,DXCNT,CNT
+5 ;
+6 ;
+7 ;Make sure needed values are defined
+8 SET X="S:$G(U)="""" U="""""
XECUTE X
+9 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+10 ;
+11 ;Reset values
+12 SET (PRMCNT,DXCNT)=0
+13 ;
+14 ;Get POV information
+15 DO POV^AMERUTIL("",VIEN,.POV)
+16 ;
+17 SET CNT=""
FOR
SET CNT=$ORDER(POV(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+18 ;Total Dx entries
SET DXCNT=DXCNT+1
+19 ;Total Primary Entries
IF $PIECE(POV(CNT),"^",2)="P"
SET PRMCNT=PRMCNT+1
End DoDot:1
+20 ;
+21 QUIT DXCNT_"^"_PRMCNT
