BQIUL1 ;PRXM/HC/DLS - Miscellaneous BQI Utilities ; 26 Oct 2005 9:43 AM
;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10
;
Q
;
FMTE(Y) ;EP - Convert Fileman Date/Time to 'MMM DD, CCYY HH:MM:SS' format.
;Description
; Receives Date (Y) in FileMan format and returns formatted date.
;
;Input
; Y - FileMan date/time (i.e. 3051024.123456).
;
;Output
; Date/Time in External format (i.e. OCT 24,2005 12:34:56).
;
NEW DATM,XX,I,V
S DATM=$TR($$FMTE^DILIBF(Y,"5U"),"@"," ")
I DATM["24:00" S DATM=$P(DATM," ",1,2)_" 00:00"
S XX="" F I=1:1:$L(DATM) S V=$E(DATM,I,I),XX=XX_V I V="," S XX=XX_" "
S DATM=XX
Q DATM
;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
;Input
; DATE - In a standard format
;Output
; -1 is if it couldn't convert to a FileMan date
; otherwise a standard FileMan date
NEW %DT,X,Y
I DATE[":" D
. I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
. I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
. I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
S %DT="TS",X=DATE D ^%DT
I Y=-1 S Y=""
;
Q Y
;
FMTMDY(DATE) ;EP - Convert fileman date to MM/DD/YYYY format
;Input
; DATE - In fileman format
;
;Output
; -1 if couldn't convert to MM/DD/YYYY format
; Otherwise, date in MM/DD/YYYY format
;
Q $TR($$FMTE^XLFDT(DATE,"5Z"),"@"," ")
;
TKO(STR,VAL) ;EP - Take off ending character
;
;Description
; This will take off the ending character at the end of
; a string
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; same STR without the ending character
;
I $G(STR)="" Q ""
I $G(VAL)="" Q ""
;
NEW LV
S LV=$L(VAL)
I $E(STR,$L(STR)-(LV-1),$L(STR))=VAL S STR=$E(STR,1,$L(STR)-LV)
;
Q STR
;
STRIP(STR,VAL) ;EP - Remove one or more trailing characters in a string.
;
;Description
; Removes one or more trailing characters
; at the end of a string.
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; Same STR without the trailing character(s).
;
I $G(STR)="" Q STR
I $G(VAL)="" Q STR
;
F Q:$E(STR,$L(STR))'=VAL S STR=$E(STR,1,($L(STR)-1))
Q STR
;
CTRL(X) ;EP - Strip out control characters
I X'?.ANP F Y=1:1 I $E(X,Y)?.C Q:Y>$L(X)!(X="") S X=$E(X,1,Y-1)_$E(X,Y+1,999),Y=Y-1
Q X
;
TRIM(STR,VAL) ;EP - Remove one or more leading characters in a string.
;
;Description
; Removes one or more leading characters from a string.
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; Same STR without the trailing character(s).
;
I $G(STR)="" Q STR
I $G(VAL)="" Q STR
;
F Q:$E(STR,1)'=VAL S STR=$E(STR,2,($L(STR)))
Q STR
;
TMPFL(MODE,UID,DFN) ;EP - Open to 'R'ead, Open to 'W'rite, 'C'lose or 'D'elete
; temporary file designed for use when converting report text to RPC
; data strings. Note that UID and DFN are components of the file name.
;
; Input
; MODE(Required) - 'R'(Read),'W'(Write),'C'(Close),'D'(Delete)
; UID(Req'd for modes D,R,W) - Job identifier
; DFN(Req'd for modes D,R,W) - Patient IEN
; Output
; POP - 0 for success, 1 for failure
;
N POP,HSPATH,HSFN
S POP=1
;
; To close a file.
I MODE="C" D CLOSE^%ZISH("BQIFILE")
;
; To Delete, Read-From, or Write-To a file.
I "D/R/W"[MODE D
.S HSPATH=$$DEFDIR^%ZISH("")
.I HSPATH="" S HSPATH=$$PWD^%ZISH()
.S HSFN=UID_"_"_$G(DFN)_".DAT"
;
; To delete a file
I MODE="D" S POP=$$DEL^%ZISH(HSPATH,HSFN)
;
; To Read from or to Write to a file.
I (MODE="R")!(MODE="W") D
.D OPEN^%ZISH("BQIFILE",HSPATH,HSFN,MODE)
Q POP
;
CMSI(X) ;EP - CMS Register Lookup
NEW DIC
S DIC(0)=$S($G(X)="":"AENZ",1:"NZ")
S DIC="^ACM(41.1," D ^DIC
S X=$P(Y,U,2) K:+Y<0 X
Q
;
PRV(VIEN) ;EP - Get PRIMARY provider for a visit
NEW PRV
S PRV=$$PRIMVPRV^PXUTL1(VIEN)
I PRV=0 S PRV=$$PROV(VIEN)
I PRV=0 Q ""
Q $$GET1^DIQ(200,PRV_",",.01,"E")
;
VVNAR(VIEN) ;EP - Get visit POV narratives
NEW IEN,POVN,TEXT,CT
S TEXT="",CT=0,IEN=""
F S IEN=$O(^AUPNVPOV("AD",VIEN,IEN)) Q:IEN="" D
. S POVN=$$GET1^DIQ(9000010.07,IEN_",",".019","E")
. I $L(TEXT)+$L(POVN)>250 Q
. S CT=CT+1
. S TEXT=TEXT_CT_")"_POVN_";"_$C(13)_$C(10)
Q $$TKO^BQIUL1(TEXT,";"_$C(13)_$C(10))
;
VPNAR(VIEN) ;EP - Get visit provider narratives
NEW IEN,PRVN,TEXT,CT
S TEXT="",CT=0,IEN=""
F S IEN=$O(^AUPNVPOV("AD",VIEN,IEN)) Q:IEN="" D
. S PRVN=$$GET1^DIQ(9000010.07,IEN_",",".04","E")
. I $L(TEXT)+$L(PRVN)>250 Q
. S CT=CT+1
. S TEXT=TEXT_CT_")"_PRVN_";"_$C(13)_$C(10)
Q $$TKO^BQIUL1(TEXT,";"_$C(13)_$C(10))
;
PROB(PIEN) ; EP - Return date/time from Problem
; Input Parameter
; PIEN = IEN of problem
;
;Since not all dates exist or are not required data entry, the
;hierachy is 'DATE ENTERED', and then 'DATE LAST MODIFIED'.
NEW VISDTM
; DATE ENTERED
S VISDTM=$$GET1^DIQ(9000011,PIEN,.08,"I")
; if for some reason DATE ENTERED doesn't exist, look at DATE LAST MODIFIED.
I VISDTM="" S VISDTM=$$GET1^DIQ(9000011,PIEN,.03,"I")
Q VISDTM
;
PROV(VIEN) ;EP - Check for Hospital Primary Provider
NEW DGADM,MIEN,PROV
S PROV=0
S DGADM=$O(^DGPM("AVISIT",VIEN,""))
I DGADM="" Q ""
S MIEN="",QFL=0
F S MIEN=$O(^DGPM("CA",DGADM,MIEN),-1) Q:MIEN=""!(QFL) D
. S PROV=$$GET1^DIQ(405,MIEN_",",.08,"I") I PROV>0 S QFL=1
Q PROV
;
HRN(BQIDFN) ;EP - Find any active HRNs for a patient
NEW HRN,FLAG,SITE
S FLAG=0,SITE=0
F S SITE=$O(^AUPNPAT(BQIDFN,41,SITE)) Q:'SITE D Q:FLAG
. I $P($G(^AUPNPAT(BQIDFN,41,SITE,0)),U,3)="" S FLAG=1
Q FLAG
;
VTHR(BQIDFN) ; EP - Find any visits in last 3 years for patient
NEW FLAG,BDATE,RVDATE,VIEN,RVSDTM,VSDTM,QFL
S FLAG=0,VIEN="",QFL=0,VSDTM=""
S BDATE=$$DATE("T-36M"),RVDATE=9999999-BDATE
S RVSDTM=$O(^AUPNVSIT("AA",BQIDFN,RVDATE),-1)
I RVSDTM'="" D
. F S VIEN=$O(^AUPNVSIT("AA",BQIDFN,RVSDTM,VIEN)) Q:VIEN="" D Q:QFL
.. I $G(^AUPNVSIT(VIEN,0))="" Q
.. S FLAG=1,QFL=1
.. S VSDTM=$P($G(^AUPNVSIT(VIEN,0)),U,1)
Q FLAG_U_VIEN_U_VSDTM
;
VTWR(BQIDFN) ; EP - Find any visits in the last 2 years for patient
NEW FLAG,BDATE,RVDATE,VIEN,RVSDTM,VSDTM,QFL
S FLAG=0,VIEN="",QFL=0,VSDTM=""
S BDATE=$$DATE("T-24M"),RVDATE=9999999-BDATE
S RVSDTM=$O(^AUPNVSIT("AA",BQIDFN,RVDATE),-1)
I RVSDTM'="" D
. F S VIEN=$O(^AUPNVSIT("AA",BQIDFN,RVSDTM,VIEN)) Q:VIEN="" D Q:QFL
.. I $G(^AUPNVSIT(VIEN,0))="" Q
.. S FLAG=1,QFL=1
.. S VSDTM=$P($G(^AUPNVSIT(VIEN,0)),U,1)
Q FLAG_U_VIEN_U_VSDTM
BQIUL1 ;PRXM/HC/DLS - Miscellaneous BQI Utilities ; 26 Oct 2005 9:43 AM
+1 ;;2.4;ICARE MANAGEMENT SYSTEM;**2**;Apr 01, 2015;Build 10
+2 ;
+3 QUIT
+4 ;
FMTE(Y) ;EP - Convert Fileman Date/Time to 'MMM DD, CCYY HH:MM:SS' format.
+1 ;Description
+2 ; Receives Date (Y) in FileMan format and returns formatted date.
+3 ;
+4 ;Input
+5 ; Y - FileMan date/time (i.e. 3051024.123456).
+6 ;
+7 ;Output
+8 ; Date/Time in External format (i.e. OCT 24,2005 12:34:56).
+9 ;
+10 NEW DATM,XX,I,V
+11 SET DATM=$TRANSLATE($$FMTE^DILIBF(Y,"5U"),"@"," ")
+12 IF DATM["24:00"
SET DATM=$PIECE(DATM," ",1,2)_" 00:00"
+13 SET XX=""
FOR I=1:1:$LENGTH(DATM)
SET V=$EXTRACT(DATM,I,I)
SET XX=XX_V
IF V=","
SET XX=XX_" "
+14 SET DATM=XX
+15 QUIT DATM
+16 ;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
+1 ;Input
+2 ; DATE - In a standard format
+3 ;Output
+4 ; -1 is if it couldn't convert to a FileMan date
+5 ; otherwise a standard FileMan date
+6 NEW %DT,X,Y
+7 IF DATE[":"
Begin DoDot:1
+8 IF DATE["/"
IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1)_"@"_$PIECE(DATE," ",2)_$PIECE(DATE," ",3)
QUIT
+9 IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1,2)_"@"_$PIECE(DATE," ",3)
+10 IF $LENGTH(DATE," ")>3
SET DATE=$PIECE(DATE," ",1,3)_"@"_$PIECE(DATE," ",4,99)
End DoDot:1
+11 SET %DT="TS"
SET X=DATE
DO ^%DT
+12 IF Y=-1
SET Y=""
+13 ;
+14 QUIT Y
+15 ;
FMTMDY(DATE) ;EP - Convert fileman date to MM/DD/YYYY format
+1 ;Input
+2 ; DATE - In fileman format
+3 ;
+4 ;Output
+5 ; -1 if couldn't convert to MM/DD/YYYY format
+6 ; Otherwise, date in MM/DD/YYYY format
+7 ;
+8 QUIT $TRANSLATE($$FMTE^XLFDT(DATE,"5Z"),"@"," ")
+9 ;
TKO(STR,VAL) ;EP - Take off ending character
+1 ;
+2 ;Description
+3 ; This will take off the ending character at the end of
+4 ; a string
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; same STR without the ending character
+10 ;
+11 IF $GET(STR)=""
QUIT ""
+12 IF $GET(VAL)=""
QUIT ""
+13 ;
+14 NEW LV
+15 SET LV=$LENGTH(VAL)
+16 IF $EXTRACT(STR,$LENGTH(STR)-(LV-1),$LENGTH(STR))=VAL
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-LV)
+17 ;
+18 QUIT STR
+19 ;
STRIP(STR,VAL) ;EP - Remove one or more trailing characters in a string.
+1 ;
+2 ;Description
+3 ; Removes one or more trailing characters
+4 ; at the end of a string.
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; Same STR without the trailing character(s).
+10 ;
+11 IF $GET(STR)=""
QUIT STR
+12 IF $GET(VAL)=""
QUIT STR
+13 ;
+14 FOR
IF $EXTRACT(STR,$LENGTH(STR))'=VAL
QUIT
SET STR=$EXTRACT(STR,1,($LENGTH(STR)-1))
+15 QUIT STR
+16 ;
CTRL(X) ;EP - Strip out control characters
+1 IF X'?.ANP
FOR Y=1:1
IF $EXTRACT(X,Y)?.C
IF Y>$LENGTH(X)!(X="")
QUIT
SET X=$EXTRACT(X,1,Y-1)_$EXTRACT(X,Y+1,999)
SET Y=Y-1
+2 QUIT X
+3 ;
TRIM(STR,VAL) ;EP - Remove one or more leading characters in a string.
+1 ;
+2 ;Description
+3 ; Removes one or more leading characters from a string.
+4 ;Input
+5 ; STR - String of data
+6 ; VAL - Delimiter character
+7 ;Output
+8 ; Same STR without the trailing character(s).
+9 ;
+10 IF $GET(STR)=""
QUIT STR
+11 IF $GET(VAL)=""
QUIT STR
+12 ;
+13 FOR
IF $EXTRACT(STR,1)'=VAL
QUIT
SET STR=$EXTRACT(STR,2,($LENGTH(STR)))
+14 QUIT STR
+15 ;
TMPFL(MODE,UID,DFN) ;EP - Open to 'R'ead, Open to 'W'rite, 'C'lose or 'D'elete
+1 ; temporary file designed for use when converting report text to RPC
+2 ; data strings. Note that UID and DFN are components of the file name.
+3 ;
+4 ; Input
+5 ; MODE(Required) - 'R'(Read),'W'(Write),'C'(Close),'D'(Delete)
+6 ; UID(Req'd for modes D,R,W) - Job identifier
+7 ; DFN(Req'd for modes D,R,W) - Patient IEN
+8 ; Output
+9 ; POP - 0 for success, 1 for failure
+10 ;
+11 NEW POP,HSPATH,HSFN
+12 SET POP=1
+13 ;
+14 ; To close a file.
+15 IF MODE="C"
DO CLOSE^%ZISH("BQIFILE")
+16 ;
+17 ; To Delete, Read-From, or Write-To a file.
+18 IF "D/R/W"[MODE
Begin DoDot:1
+19 SET HSPATH=$$DEFDIR^%ZISH("")
+20 IF HSPATH=""
SET HSPATH=$$PWD^%ZISH()
+21 SET HSFN=UID_"_"_$GET(DFN)_".DAT"
End DoDot:1
+22 ;
+23 ; To delete a file
+24 IF MODE="D"
SET POP=$$DEL^%ZISH(HSPATH,HSFN)
+25 ;
+26 ; To Read from or to Write to a file.
+27 IF (MODE="R")!(MODE="W")
Begin DoDot:1
+28 DO OPEN^%ZISH("BQIFILE",HSPATH,HSFN,MODE)
End DoDot:1
+29 QUIT POP
+30 ;
CMSI(X) ;EP - CMS Register Lookup
+1 NEW DIC
+2 SET DIC(0)=$SELECT($GET(X)="":"AENZ",1:"NZ")
+3 SET DIC="^ACM(41.1,"
DO ^DIC
+4 SET X=$PIECE(Y,U,2)
IF +Y<0
KILL X
+5 QUIT
+6 ;
PRV(VIEN) ;EP - Get PRIMARY provider for a visit
+1 NEW PRV
+2 SET PRV=$$PRIMVPRV^PXUTL1(VIEN)
+3 IF PRV=0
SET PRV=$$PROV(VIEN)
+4 IF PRV=0
QUIT ""
+5 QUIT $$GET1^DIQ(200,PRV_",",.01,"E")
+6 ;
VVNAR(VIEN) ;EP - Get visit POV narratives
+1 NEW IEN,POVN,TEXT,CT
+2 SET TEXT=""
SET CT=0
SET IEN=""
+3 FOR
SET IEN=$ORDER(^AUPNVPOV("AD",VIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+4 SET POVN=$$GET1^DIQ(9000010.07,IEN_",",".019","E")
+5 IF $LENGTH(TEXT)+$LENGTH(POVN)>250
QUIT
+6 SET CT=CT+1
+7 SET TEXT=TEXT_CT_")"_POVN_";"_$CHAR(13)_$CHAR(10)
End DoDot:1
+8 QUIT $$TKO^BQIUL1(TEXT,";"_$CHAR(13)_$CHAR(10))
+9 ;
VPNAR(VIEN) ;EP - Get visit provider narratives
+1 NEW IEN,PRVN,TEXT,CT
+2 SET TEXT=""
SET CT=0
SET IEN=""
+3 FOR
SET IEN=$ORDER(^AUPNVPOV("AD",VIEN,IEN))
IF IEN=""
QUIT
Begin DoDot:1
+4 SET PRVN=$$GET1^DIQ(9000010.07,IEN_",",".04","E")
+5 IF $LENGTH(TEXT)+$LENGTH(PRVN)>250
QUIT
+6 SET CT=CT+1
+7 SET TEXT=TEXT_CT_")"_PRVN_";"_$CHAR(13)_$CHAR(10)
End DoDot:1
+8 QUIT $$TKO^BQIUL1(TEXT,";"_$CHAR(13)_$CHAR(10))
+9 ;
PROB(PIEN) ; EP - Return date/time from Problem
+1 ; Input Parameter
+2 ; PIEN = IEN of problem
+3 ;
+4 ;Since not all dates exist or are not required data entry, the
+5 ;hierachy is 'DATE ENTERED', and then 'DATE LAST MODIFIED'.
+6 NEW VISDTM
+7 ; DATE ENTERED
+8 SET VISDTM=$$GET1^DIQ(9000011,PIEN,.08,"I")
+9 ; if for some reason DATE ENTERED doesn't exist, look at DATE LAST MODIFIED.
+10 IF VISDTM=""
SET VISDTM=$$GET1^DIQ(9000011,PIEN,.03,"I")
+11 QUIT VISDTM
+12 ;
PROV(VIEN) ;EP - Check for Hospital Primary Provider
+1 NEW DGADM,MIEN,PROV
+2 SET PROV=0
+3 SET DGADM=$ORDER(^DGPM("AVISIT",VIEN,""))
+4 IF DGADM=""
QUIT ""
+5 SET MIEN=""
SET QFL=0
+6 FOR
SET MIEN=$ORDER(^DGPM("CA",DGADM,MIEN),-1)
IF MIEN=""!(QFL)
QUIT
Begin DoDot:1
+7 SET PROV=$$GET1^DIQ(405,MIEN_",",.08,"I")
IF PROV>0
SET QFL=1
End DoDot:1
+8 QUIT PROV
+9 ;
HRN(BQIDFN) ;EP - Find any active HRNs for a patient
+1 NEW HRN,FLAG,SITE
+2 SET FLAG=0
SET SITE=0
+3 FOR
SET SITE=$ORDER(^AUPNPAT(BQIDFN,41,SITE))
IF 'SITE
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^AUPNPAT(BQIDFN,41,SITE,0)),U,3)=""
SET FLAG=1
End DoDot:1
IF FLAG
QUIT
+5 QUIT FLAG
+6 ;
VTHR(BQIDFN) ; EP - Find any visits in last 3 years for patient
+1 NEW FLAG,BDATE,RVDATE,VIEN,RVSDTM,VSDTM,QFL
+2 SET FLAG=0
SET VIEN=""
SET QFL=0
SET VSDTM=""
+3 SET BDATE=$$DATE("T-36M")
SET RVDATE=9999999-BDATE
+4 SET RVSDTM=$ORDER(^AUPNVSIT("AA",BQIDFN,RVDATE),-1)
+5 IF RVSDTM'=""
Begin DoDot:1
+6 FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",BQIDFN,RVSDTM,VIEN))
IF VIEN=""
QUIT
Begin DoDot:2
+7 IF $GET(^AUPNVSIT(VIEN,0))=""
QUIT
+8 SET FLAG=1
SET QFL=1
+9 SET VSDTM=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
End DoDot:2
IF QFL
QUIT
End DoDot:1
+10 QUIT FLAG_U_VIEN_U_VSDTM
+11 ;
VTWR(BQIDFN) ; EP - Find any visits in the last 2 years for patient
+1 NEW FLAG,BDATE,RVDATE,VIEN,RVSDTM,VSDTM,QFL
+2 SET FLAG=0
SET VIEN=""
SET QFL=0
SET VSDTM=""
+3 SET BDATE=$$DATE("T-24M")
SET RVDATE=9999999-BDATE
+4 SET RVSDTM=$ORDER(^AUPNVSIT("AA",BQIDFN,RVDATE),-1)
+5 IF RVSDTM'=""
Begin DoDot:1
+6 FOR
SET VIEN=$ORDER(^AUPNVSIT("AA",BQIDFN,RVSDTM,VIEN))
IF VIEN=""
QUIT
Begin DoDot:2
+7 IF $GET(^AUPNVSIT(VIEN,0))=""
QUIT
+8 SET FLAG=1
SET QFL=1
+9 SET VSDTM=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
End DoDot:2
IF QFL
QUIT
End DoDot:1
+10 QUIT FLAG_U_VIEN_U_VSDTM
