BGOUTL2 ; IHS/BAO/TMD - Utilities (continued) ;05-Jun-2014 08:41;DU
;;1.1;BGO COMPONENTS;**1,3,5,6,10,11,12,13,14**;Mar 20, 2007;Build 13
; Add refusals to output stream
; R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
; Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
; Added AICD lookup
REFGET(RET,DFN,FNUM,CNT) ;EP
N TYPE,VDT,RIEN,REC,TYPNM,DATE,REASON,COMMENT,PRV,PRVNM
S TYPE=0,CNT=+$G(CNT)
S:$G(RET)="" RET=$$TMPGBL^BGOUTL
F S TYPE=$O(^AUPNPREF("AA",DFN,FNUM,TYPE)) Q:'TYPE D
.S VDT=0
.F S VDT=$O(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT)) Q:'VDT D
..S RIEN=0
..F S RIEN=$O(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT,RIEN)) Q:'RIEN D
...S CNT=CNT+1,@RET@(CNT)=$$REFGET1(RIEN)
Q
; Return data for a specified refusal
; R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
; Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
REFGET1(RIEN) ;EP
N REC,PRV,COMMENT,TYPE,TYPENM,REASON,DATE,PRVNM,FNUM,ITEM,ITEMNM,ARR,IN,OUT,X,SNTXT
S REC=$G(^AUPNPREF(RIEN,0)),PRV=$P($G(^(12)),U,4),COMMENT=$P($G(^(11)),U)
Q:REC=""
S SNTXT=""
S TYPE=+REC
S TYPENM=$P($G(^AUTTREFT(TYPE,0)),U)
S DATE=$$FMTDATE^BGOUTL($P(REC,U,3))
S ITEMNM=$P(REC,U,4)
;IHS/MSC/MGH Patch 13
I TYPENM="SNOMED" D
.S ITEM=$P($G(^AUPNPREF(RIEN,13)),U,1)
.S X=$$CONC^BSTSAPI(ITEM_"^^^1")
.S ITEMNM=$P(X,U,4)
E D
.S FNUM=$P(REC,U,5)
.S ITEM=$P(REC,U,6)
.S:ITEMNM="" ITEMNM=$$GET1^DIQ(FNUM,ITEM,.01)
S REASON=$$EXTERNAL^DILFD(9000022,.07,,$P(REC,U,7))
;IHS/MSC/MGH patch 13
S CT=$P($G(^AUPNPREF(RIEN,1)),U,1)
I CT'="" D
.;S IN=CT_"^^^1"
.;S OUT="ARR"
.;S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
.;I X>0 D
.;.S SNTXT=@OUT@(1,"PRE","TRM")
.S X=$$CONC^BSTSAPI(CT_"^^^1")
.S SNTXT=$P(X,U,4)
S PRVNM=$S(PRV:$$GET1^DIQ(200,PRV,.01),1:"")
I TYPENM="EDUCATION TOPICS" D
.N TXT,SNO,IN,X,TOPTYP
.Q:'+ITEM
.I $P($G(^AUTTEDT(ITEM,0)),U,12)'="" D
..S TXT=""
..S SNO=$P($G(^AUTTEDT(ITEM,0)),U,12)
..S IN=SNO_U_36_U_U_1
..S X=$$CONC^BSTSAPI(IN)
..S TXT=$P(X,U,4)
..S TOPTYP=$P($P($G(^AUTTEDT(ITEM,0)),U,1),"-",2)
..S ITEMNM=TXT_"-"_TOPTYP
Q "R"_U_RIEN_U_TYPE_U_TYPENM_U_ITEM_U_ITEMNM_U_PRV_U_PRVNM_U_DATE_U_$$REFLCK(RIEN)_U_REASON_U_COMMENT_U_SNTXT
; Store a patient refusal (using visit IEN)
REFSET(VIEN,ITEM,TYPE,RSN,CMNT,PRV,CT) ;EP
N X,RIEN
S RIEN=""
S X=$G(^AUPNVSIT(VIEN,0))
;Q $$REFSET2($P(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,IEN,CT)
Q $$REFSET2($P(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,RIEN,.CT) ;2013-10-02 DKA P13 Correct <UNDEFINED> error
; Store a patient refusal (alternate)
REFSET2(DFN,DAT,ITEM,TYPE,RSN,CMNT,PRV,RIEN,CT) ;EP
N FDA,ERR,FNUM,RET,IENX,OPR,ZN,CPT,IN,OUT,X,ARR,SNO
S CT=$G(CT),RIEN=$G(RIEN)
S CPT=$$FIND1^DIC(9999999.73,,"X","CPT") ;Patch 10 IHS/MSC/MGH
S SNO=$$FIND1^DIC(9999999.73,,"X","SNOMED") ;Patch 13
S TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
Q:'TYPE $$ERR^BGOUTL(1067)
S FNUM=$P(^AUTTREFT(TYPE,0),U,2),OPR=1
S:'$G(RIEN) RIEN=$O(^AUPNPREF("AA",DFN,FNUM,ITEM,9999999-DAT,0))
;I "@"[RSN Q:'RIEN S TYPE="@",OPR=2
I "@"[RSN,RIEN S TYPE="@",OPR=2
S:'RIEN RIEN="+1",OPR=0
S:OPR=2 ZN=$G(^AUPNPREF(RIEN,0))
S FDA=$NA(FDA(9000022,RIEN_","))
S @FDA@(.01)="`"_TYPE
S:'OPR @FDA@(.02)="`"_DFN
S @FDA@(.03)=DAT
S @FDA@(.08)=DAT
;IHS/MSC/MGH Added storing narrative for CPT codes Patch 10
I TYPE=CPT S @FDA@(.04)=$E($$GET1^DIQ(FNUM,ITEM,2),1,80)
E D
.I TYPE=SNO D
..S @FDA@(1301)=ITEM
..S @FDA@(.06)=ITEM
..K ARR
..S IN=ITEM_"^^^1"
..S OUT="ARR"
..S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
..I X>0 D
...S @FDA@(1302)=ARR(1,"PRE","DSC")
...S @FDA@(.04)=ARR(1,"PRE","TRM")
..;END patch 13 mod
.E S @FDA@(.04)=$E($$GET1^DIQ(FNUM,ITEM,.01),1,80)
S @FDA@(.05)=FNUM
S @FDA@(.06)=ITEM
S @FDA@(.07)=RSN
;IHS/MSC/MGH Patch 13 Added for reason
K ARR
I CT'="" D
.S IN=CT_"^^^1^"
.S OUT="ARR"
.S @FDA@(1.01)=CT
.S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
.I X>0 D
..S @FDA@(1.02)=ARR(1,"PRE","DSC")
.;END patch 13 mod
S:$D(CMNT) @FDA@(1101)=CMNT
S:'$G(PRV) PRV=DUZ
S @FDA@(1204)="`"_PRV
;IHS/MSC/MGH new fields patch 11
I $E(RIEN)="+" D
.S @FDA@(1216)="N"
.S @FDA@(1217)="`"_DUZ
S @FDA@(1218)="N"
S @FDA@(1219)="`"_DUZ
S RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
S:$E(RIEN)="+" RIEN=$G(IENX(1))
D:'RET REFEVT(RIEN,OPR,.ZN)
Q RET
; Delete a refusal
REFDEL(IEN) ;EP
N RET,X
S X=$G(^AUPNPREF(IEN,0))
Q:'$L(X) ""
S RET=$$DELETE^BGOUTL("^AUPNPREF(",IEN)
D:'RET REFEVT(IEN,2,X)
Q RET
; Delete a refusal (alternate)
REFDEL2(VIEN,ITEM,TYPE) ;EP
N X,FNUM
S TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
Q:'TYPE $$ERR^BGOUTL(1067)
S FNUM=$P(^AUTTREFT(TYPE,0),U,2)
S X=$G(^AUPNVSIT(VIEN,0))
Q $$REFDEL(+$O(^AUPNPREF("AA",+$P(X,U,5),FNUM,ITEM,9999999-(X\1),0)))
; Broadcast a refusal event
REFEVT(IEN,OPR,X) ;EP
N DFN,TYPE
S:'$D(X) X=$G(^AUPNPREF(IEN,0))
S DFN=$P(X,U,2)
Q:'DFN
S TYPE=$P($G(^AUTTREFT(+X,0)),U)
D BRDCAST^CIANBEVT("REFUSAL."_DFN_"."_TYPE,IEN_U_$G(CIA("UID"))_U_OPR)
Q
; Returns true if a refusal is locked against editing
REFLCK(IEN) ;EP
N DAT,DAYS
S DAT=+$P($G(^AUPNPREF(IEN,0)),U,3)
S DAYS=$$GET^XPAR("ALL","BEHOENCX VISIT LOCKED")
Q $S('DAT:-1,1:$$FMDIFF^XLFDT(DT,DAT)>$S(DAYS<1:1,1:DAYS))
; Check for duplicate V File type in a visit
; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFCHK(RET,FNUM,TYPE,ENTITY,VIEN,EIEFLD) ;EP ;DKA 7/12/13 Add EIEFLD to specify Entered in Error field
;D VFFND(.RET,FNUM,TYPE,VIEN)
D VFFND(.RET,FNUM,TYPE,VIEN,.EIEFLD)
S:RET RET=$$ERR^BGOUTL(1068,ENTITY)_U_RET
Q
; Locate a V File entry
; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFFND(RET,FNUM,TYPE,VIEN,EIEFLD) ;EP
N X,GBL
S GBL=$$ROOT^DILFD(FNUM,,1)
I '$L(GBL) S RET=$$ERR^BGOUTL(1069) Q
S X=0,RET=""
F S X=$O(@GBL@("AD",VIEN,X)) Q:'X D Q:RET
.I FNUM=9000010.51,$G(EIEFLD)=1.01,$P($G(@GBL@(X,1)),U) Q ; DKA 7/12/13 Ignore Entered in Error entries
.S:$P($G(@GBL@(X,0)),U)=TYPE RET=X
Q
; Create root V File entry
; FNUM = File number
; TYPE = Entry type (.01 of V File)
; VIEN = Visit IEN
; NAME = Name of entity (if checking for dups)
; FLDS = Additional field values (optional)
; .RET = IEN of new entry or -1^error text
; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFNEW(RET,FNUM,TYPE,VIEN,NAME,FLDS,EIEFLD) ;EP
N FDA,IEN,V0,CAT,APCDVSIT,PXCEVIEN
S V0=$G(^AUPNVSIT(VIEN,0)),CAT=$P(V0,U,7)
;I $L($G(NAME)),CAT'="H" D VFCHK(.RET,FNUM,TYPE,NAME,VIEN) Q:RET
I $L($G(NAME)),CAT'="H" D VFCHK(.RET,FNUM,TYPE,NAME,VIEN,.EIEFLD) Q:RET
I $G(DUZ("AG"))="I" S APCDVSIT=VIEN
E S PXCEVIEN=VIEN
S FDA=$NA(FDA(FNUM,"+1,"))
S @FDA@(.01)=TYPE
S @FDA@(.02)=$P(V0,U,5)
S @FDA@(.03)=VIEN
S:$D(^DD(FNUM,1201,0)) @FDA@(1201)=$S(CAT="H":$$NOW^XLFDT,1:+V0)
M @FDA=FLDS
S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
S:'RET RET=IEN(1)
Q
; Delete V File entry
VFDEL(RET,FNUM,VFIEN) ;EP
N VIEN,GBL,X
S GBL=$$ROOT^DILFD(FNUM,,1),RET=""
Q:'VFIEN
I '$L(GBL) S RET=$$ERR^BGOUTL(1069) Q
S X=$G(@GBL@(VFIEN,0))
S VIEN=$P(X,U,3)
Q:'VIEN
S RET=$$CHKVISIT^BGOUTL(VIEN)
S:'RET RET=$$DELETE^BGOUTL(FNUM,VFIEN)
D:'RET VFEVT(FNUM,VFIEN,2,X)
Q
; Fetch V File entries
; INP = Patient IEN (for entries associated with a patient) [1] ^
; V File IEN (for single entry) [2] ^
; Visit IEN (for entries associated with a visit) [3]
; FNUM= V File #
; FLDS= Fields to retrieve
VFGET(RET,INP,FNUM,FLDS) ;EP
N VFIEN,VIEN,DFN,GBL,CNT,XREF,X
S RET=$$TMPGBL^BGOUTL
S GBL=$$ROOT^DILFD(FNUM,,1)
I '$L(GBL) S @RET@(1)=$$ERR^BGOUTL(1069) Q
S CNT=0
S DFN=+INP
S VFIEN=$P(INP,U,2)
S VIEN=$P(INP,U,3)
I VFIEN D
.I '$D(@GBL@(VFIEN,0)) S @RET@(1)=$$ERR^BGOUTL(1070)
.E D GV1
E I VIEN D
.S VFIEN=0
.F S VFIEN=$O(@GBL@("AD",VIEN,VFIEN)) Q:'VFIEN D GV1
E I DFN D
.S VFIEN="",XREF=$$VFPTXREF ;P6
.F S VFIEN=$O(@GBL@(XREF,DFN,VFIEN),-1) Q:'VFIEN D GV1
E S @RET@(1)=$$ERR^BGOUTL(1008)
Q
GV1 S X=$$GETREC^BGOUTL(FNUM,VFIEN,FLDS)
S CNT=CNT+1,@RET@(CNT)=$P(X,U)_U_$$ISLOCKED^BEHOENCX(+$P($G(@GBL@(VFIEN,0)),U,3))_U_$P(X,U,2,9999)
Q
; Fire V file update events
; FNUM = V File #
; VFIEN = V File IEN
; OPR = Operation (0 = add, 1 = edit, 2 = delete)
VFEVT(FNUM,VFIEN,OPR,X) ;EP
N ID,GBL,DFN,VIEN,DATA
S GBL=$$ROOT^DILFD(FNUM,,1)
Q:'$L(GBL)
Q:'$G(VFIEN) ;P6
S ID=$P(GBL,"AUPNV",2)
S:'$D(X) X=$G(@GBL@(VFIEN,0))
S DFN=$P(X,U,2),VIEN=$P(X,U,3),DATA=VFIEN_U_$G(CIA("UID"))_U_OPR_U_$P(X,U)_U_VIEN
D:DFN BRDCAST^CIANBEVT("PCC."_DFN_"."_ID,DATA)
D:VIEN BRDCAST^CIANBEVT("VISIT."_VIEN_"."_ID,DATA)
D:VIEN VFMOD(VIEN)
Q
; Update the visit modification date
VFMOD(AUPNVSIT) ;EP
Q:$G(DUZ("AG"))'="I" ;P6
N DIE,DA,DR,DIU,DIV
D MOD^AUPNVSIT
Q
; Returns patient xref for V files
VFPTXREF() ;
Q $S($G(DUZ("AG"))="I":"AC",1:"C")
; Find/create narrative text in narrative file, returning IEN
FNDNARR(NARR,CREATE) ;EP
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))
;Return a subset list from the Apelon tool
SUBSET(RET,SUBSET) ; EP
N OUT,IN,X
S RET=$$SNOTMP
S OUT="ARR"
S IN=SUBSET_"^36^1"
S X=$$SUBLST^BSTSAPI(.OUT,.IN)
;1 means success
I X>0 D
.M @RET=@OUT
Q
SNOTMP() K ^TMP("BGOSN",$J) Q $NA(^($J))
; Returns true if CSV is active
CSVACT(RTN) ;EP
Q $S(DUZ("AG")'="I":1,$$VERSION^XPDUTL("BCSV")="":0,'$L($G(RTN)):1,1:$T(+0^@RTN)'="")
AICD() ;EP
Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
; Get the SNOMED data for a Concept ID
SNMDCONC(RET,CONCID) ; EP
S RET=$$CONC^BSTSAPI($G(CONCID))
Q
BGOUTL2 ; IHS/BAO/TMD - Utilities (continued) ;05-Jun-2014 08:41;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,5,6,10,11,12,13,14**;Mar 20, 2007;Build 13
+2 ; Add refusals to output stream
+3 ; R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
+4 ; Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
+5 ; Added AICD lookup
REFGET(RET,DFN,FNUM,CNT) ;EP
+1 NEW TYPE,VDT,RIEN,REC,TYPNM,DATE,REASON,COMMENT,PRV,PRVNM
+2 SET TYPE=0
SET CNT=+$GET(CNT)
+3 IF $GET(RET)=""
SET RET=$$TMPGBL^BGOUTL
+4 FOR
SET TYPE=$ORDER(^AUPNPREF("AA",DFN,FNUM,TYPE))
IF 'TYPE
QUIT
Begin DoDot:1
+5 SET VDT=0
+6 FOR
SET VDT=$ORDER(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT))
IF 'VDT
QUIT
Begin DoDot:2
+7 SET RIEN=0
+8 FOR
SET RIEN=$ORDER(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT,RIEN))
IF 'RIEN
QUIT
Begin DoDot:3
+9 SET CNT=CNT+1
SET @RET@(CNT)=$$REFGET1(RIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ; Return data for a specified refusal
+12 ; R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
+13 ; Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
REFGET1(RIEN) ;EP
+1 NEW REC,PRV,COMMENT,TYPE,TYPENM,REASON,DATE,PRVNM,FNUM,ITEM,ITEMNM,ARR,IN,OUT,X,SNTXT
+2 SET REC=$GET(^AUPNPREF(RIEN,0))
SET PRV=$PIECE($GET(^(12)),U,4)
SET COMMENT=$PIECE($GET(^(11)),U)
+3 IF REC=""
QUIT
+4 SET SNTXT=""
+5 SET TYPE=+REC
+6 SET TYPENM=$PIECE($GET(^AUTTREFT(TYPE,0)),U)
+7 SET DATE=$$FMTDATE^BGOUTL($PIECE(REC,U,3))
+8 SET ITEMNM=$PIECE(REC,U,4)
+9 ;IHS/MSC/MGH Patch 13
+10 IF TYPENM="SNOMED"
Begin DoDot:1
+11 SET ITEM=$PIECE($GET(^AUPNPREF(RIEN,13)),U,1)
+12 SET X=$$CONC^BSTSAPI(ITEM_"^^^1")
+13 SET ITEMNM=$PIECE(X,U,4)
End DoDot:1
+14 IF '$TEST
Begin DoDot:1
+15 SET FNUM=$PIECE(REC,U,5)
+16 SET ITEM=$PIECE(REC,U,6)
+17 IF ITEMNM=""
SET ITEMNM=$$GET1^DIQ(FNUM,ITEM,.01)
End DoDot:1
+18 SET REASON=$$EXTERNAL^DILFD(9000022,.07,,$PIECE(REC,U,7))
+19 ;IHS/MSC/MGH patch 13
+20 SET CT=$PIECE($GET(^AUPNPREF(RIEN,1)),U,1)
+21 IF CT'=""
Begin DoDot:1
+22 ;S IN=CT_"^^^1"
+23 ;S OUT="ARR"
+24 ;S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+25 ;I X>0 D
+26 ;.S SNTXT=@OUT@(1,"PRE","TRM")
+27 SET X=$$CONC^BSTSAPI(CT_"^^^1")
+28 SET SNTXT=$PIECE(X,U,4)
End DoDot:1
+29 SET PRVNM=$SELECT(PRV:$$GET1^DIQ(200,PRV,.01),1:"")
+30 IF TYPENM="EDUCATION TOPICS"
Begin DoDot:1
+31 NEW TXT,SNO,IN,X,TOPTYP
+32 IF '+ITEM
QUIT
+33 IF $PIECE($GET(^AUTTEDT(ITEM,0)),U,12)'=""
Begin DoDot:2
+34 SET TXT=""
+35 SET SNO=$PIECE($GET(^AUTTEDT(ITEM,0)),U,12)
+36 SET IN=SNO_U_36_U_U_1
+37 SET X=$$CONC^BSTSAPI(IN)
+38 SET TXT=$PIECE(X,U,4)
+39 SET TOPTYP=$PIECE($PIECE($GET(^AUTTEDT(ITEM,0)),U,1),"-",2)
+40 SET ITEMNM=TXT_"-"_TOPTYP
End DoDot:2
End DoDot:1
+41 QUIT "R"_U_RIEN_U_TYPE_U_TYPENM_U_ITEM_U_ITEMNM_U_PRV_U_PRVNM_U_DATE_U_$$REFLCK(RIEN)_U_REASON_U_COMMENT_U_SNTXT
+42 ; Store a patient refusal (using visit IEN)
REFSET(VIEN,ITEM,TYPE,RSN,CMNT,PRV,CT) ;EP
+1 NEW X,RIEN
+2 SET RIEN=""
+3 SET X=$GET(^AUPNVSIT(VIEN,0))
+4 ;Q $$REFSET2($P(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,IEN,CT)
+5 ;2013-10-02 DKA P13 Correct <UNDEFINED> error
QUIT $$REFSET2($PIECE(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,RIEN,.CT)
+6 ; Store a patient refusal (alternate)
REFSET2(DFN,DAT,ITEM,TYPE,RSN,CMNT,PRV,RIEN,CT) ;EP
+1 NEW FDA,ERR,FNUM,RET,IENX,OPR,ZN,CPT,IN,OUT,X,ARR,SNO
+2 SET CT=$GET(CT)
SET RIEN=$GET(RIEN)
+3 ;Patch 10 IHS/MSC/MGH
SET CPT=$$FIND1^DIC(9999999.73,,"X","CPT")
+4 ;Patch 13
SET SNO=$$FIND1^DIC(9999999.73,,"X","SNOMED")
+5 SET TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
+6 IF 'TYPE
QUIT $$ERR^BGOUTL(1067)
+7 SET FNUM=$PIECE(^AUTTREFT(TYPE,0),U,2)
SET OPR=1
+8 IF '$GET(RIEN)
SET RIEN=$ORDER(^AUPNPREF("AA",DFN,FNUM,ITEM,9999999-DAT,0))
+9 ;I "@"[RSN Q:'RIEN S TYPE="@",OPR=2
+10 IF "@"[RSN
IF RIEN
SET TYPE="@"
SET OPR=2
+11 IF 'RIEN
SET RIEN="+1"
SET OPR=0
+12 IF OPR=2
SET ZN=$GET(^AUPNPREF(RIEN,0))
+13 SET FDA=$NAME(FDA(9000022,RIEN_","))
+14 SET @FDA@(.01)="`"_TYPE
+15 IF 'OPR
SET @FDA@(.02)="`"_DFN
+16 SET @FDA@(.03)=DAT
+17 SET @FDA@(.08)=DAT
+18 ;IHS/MSC/MGH Added storing narrative for CPT codes Patch 10
+19 IF TYPE=CPT
SET @FDA@(.04)=$EXTRACT($$GET1^DIQ(FNUM,ITEM,2),1,80)
+20 IF '$TEST
Begin DoDot:1
+21 IF TYPE=SNO
Begin DoDot:2
+22 SET @FDA@(1301)=ITEM
+23 SET @FDA@(.06)=ITEM
+24 KILL ARR
+25 SET IN=ITEM_"^^^1"
+26 SET OUT="ARR"
+27 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+28 IF X>0
Begin DoDot:3
+29 SET @FDA@(1302)=ARR(1,"PRE","DSC")
+30 SET @FDA@(.04)=ARR(1,"PRE","TRM")
End DoDot:3
+31 ;END patch 13 mod
End DoDot:2
+32 IF '$TEST
SET @FDA@(.04)=$EXTRACT($$GET1^DIQ(FNUM,ITEM,.01),1,80)
End DoDot:1
+33 SET @FDA@(.05)=FNUM
+34 SET @FDA@(.06)=ITEM
+35 SET @FDA@(.07)=RSN
+36 ;IHS/MSC/MGH Patch 13 Added for reason
+37 KILL ARR
+38 IF CT'=""
Begin DoDot:1
+39 SET IN=CT_"^^^1^"
+40 SET OUT="ARR"
+41 SET @FDA@(1.01)=CT
+42 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+43 IF X>0
Begin DoDot:2
+44 SET @FDA@(1.02)=ARR(1,"PRE","DSC")
End DoDot:2
+45 ;END patch 13 mod
End DoDot:1
+46 IF $DATA(CMNT)
SET @FDA@(1101)=CMNT
+47 IF '$GET(PRV)
SET PRV=DUZ
+48 SET @FDA@(1204)="`"_PRV
+49 ;IHS/MSC/MGH new fields patch 11
+50 IF $EXTRACT(RIEN)="+"
Begin DoDot:1
+51 SET @FDA@(1216)="N"
+52 SET @FDA@(1217)="`"_DUZ
End DoDot:1
+53 SET @FDA@(1218)="N"
+54 SET @FDA@(1219)="`"_DUZ
+55 SET RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
+56 IF $EXTRACT(RIEN)="+"
SET RIEN=$GET(IENX(1))
+57 IF 'RET
DO REFEVT(RIEN,OPR,.ZN)
+58 QUIT RET
+59 ; Delete a refusal
REFDEL(IEN) ;EP
+1 NEW RET,X
+2 SET X=$GET(^AUPNPREF(IEN,0))
+3 IF '$LENGTH(X)
QUIT ""
+4 SET RET=$$DELETE^BGOUTL("^AUPNPREF(",IEN)
+5 IF 'RET
DO REFEVT(IEN,2,X)
+6 QUIT RET
+7 ; Delete a refusal (alternate)
REFDEL2(VIEN,ITEM,TYPE) ;EP
+1 NEW X,FNUM
+2 SET TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
+3 IF 'TYPE
QUIT $$ERR^BGOUTL(1067)
+4 SET FNUM=$PIECE(^AUTTREFT(TYPE,0),U,2)
+5 SET X=$GET(^AUPNVSIT(VIEN,0))
+6 QUIT $$REFDEL(+$ORDER(^AUPNPREF("AA",+$PIECE(X,U,5),FNUM,ITEM,9999999-(X\1),0)))
+7 ; Broadcast a refusal event
REFEVT(IEN,OPR,X) ;EP
+1 NEW DFN,TYPE
+2 IF '$DATA(X)
SET X=$GET(^AUPNPREF(IEN,0))
+3 SET DFN=$PIECE(X,U,2)
+4 IF 'DFN
QUIT
+5 SET TYPE=$PIECE($GET(^AUTTREFT(+X,0)),U)
+6 DO BRDCAST^CIANBEVT("REFUSAL."_DFN_"."_TYPE,IEN_U_$GET(CIA("UID"))_U_OPR)
+7 QUIT
+8 ; Returns true if a refusal is locked against editing
REFLCK(IEN) ;EP
+1 NEW DAT,DAYS
+2 SET DAT=+$PIECE($GET(^AUPNPREF(IEN,0)),U,3)
+3 SET DAYS=$$GET^XPAR("ALL","BEHOENCX VISIT LOCKED")
+4 QUIT $SELECT('DAT:-1,1:$$FMDIFF^XLFDT(DT,DAT)>$SELECT(DAYS<1:1,1:DAYS))
+5 ; Check for duplicate V File type in a visit
+6 ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFCHK(RET,FNUM,TYPE,ENTITY,VIEN,EIEFLD) ;EP ;DKA 7/12/13 Add EIEFLD to specify Entered in Error field
+1 ;D VFFND(.RET,FNUM,TYPE,VIEN)
+2 DO VFFND(.RET,FNUM,TYPE,VIEN,.EIEFLD)
+3 IF RET
SET RET=$$ERR^BGOUTL(1068,ENTITY)_U_RET
+4 QUIT
+5 ; Locate a V File entry
+6 ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFFND(RET,FNUM,TYPE,VIEN,EIEFLD) ;EP
+1 NEW X,GBL
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
+3 IF '$LENGTH(GBL)
SET RET=$$ERR^BGOUTL(1069)
QUIT
+4 SET X=0
SET RET=""
+5 FOR
SET X=$ORDER(@GBL@("AD",VIEN,X))
IF 'X
QUIT
Begin DoDot:1
+6 ; DKA 7/12/13 Ignore Entered in Error entries
IF FNUM=9000010.51
IF $GET(EIEFLD)=1.01
IF $PIECE($GET(@GBL@(X,1)),U)
QUIT
+7 IF $PIECE($GET(@GBL@(X,0)),U)=TYPE
SET RET=X
End DoDot:1
IF RET
QUIT
+8 QUIT
+9 ; Create root V File entry
+10 ; FNUM = File number
+11 ; TYPE = Entry type (.01 of V File)
+12 ; VIEN = Visit IEN
+13 ; NAME = Name of entity (if checking for dups)
+14 ; FLDS = Additional field values (optional)
+15 ; .RET = IEN of new entry or -1^error text
+16 ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
VFNEW(RET,FNUM,TYPE,VIEN,NAME,FLDS,EIEFLD) ;EP
+1 NEW FDA,IEN,V0,CAT,APCDVSIT,PXCEVIEN
+2 SET V0=$GET(^AUPNVSIT(VIEN,0))
SET CAT=$PIECE(V0,U,7)
+3 ;I $L($G(NAME)),CAT'="H" D VFCHK(.RET,FNUM,TYPE,NAME,VIEN) Q:RET
+4 IF $LENGTH($GET(NAME))
IF CAT'="H"
DO VFCHK(.RET,FNUM,TYPE,NAME,VIEN,.EIEFLD)
IF RET
QUIT
+5 IF $GET(DUZ("AG"))="I"
SET APCDVSIT=VIEN
+6 IF '$TEST
SET PXCEVIEN=VIEN
+7 SET FDA=$NAME(FDA(FNUM,"+1,"))
+8 SET @FDA@(.01)=TYPE
+9 SET @FDA@(.02)=$PIECE(V0,U,5)
+10 SET @FDA@(.03)=VIEN
+11 IF $DATA(^DD(FNUM,1201,0))
SET @FDA@(1201)=$SELECT(CAT="H":$$NOW^XLFDT,1:+V0)
+12 MERGE @FDA=FLDS
+13 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+14 IF 'RET
SET RET=IEN(1)
+15 QUIT
+16 ; Delete V File entry
VFDEL(RET,FNUM,VFIEN) ;EP
+1 NEW VIEN,GBL,X
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
SET RET=""
+3 IF 'VFIEN
QUIT
+4 IF '$LENGTH(GBL)
SET RET=$$ERR^BGOUTL(1069)
QUIT
+5 SET X=$GET(@GBL@(VFIEN,0))
+6 SET VIEN=$PIECE(X,U,3)
+7 IF 'VIEN
QUIT
+8 SET RET=$$CHKVISIT^BGOUTL(VIEN)
+9 IF 'RET
SET RET=$$DELETE^BGOUTL(FNUM,VFIEN)
+10 IF 'RET
DO VFEVT(FNUM,VFIEN,2,X)
+11 QUIT
+12 ; Fetch V File entries
+13 ; INP = Patient IEN (for entries associated with a patient) [1] ^
+14 ; V File IEN (for single entry) [2] ^
+15 ; Visit IEN (for entries associated with a visit) [3]
+16 ; FNUM= V File #
+17 ; FLDS= Fields to retrieve
VFGET(RET,INP,FNUM,FLDS) ;EP
+1 NEW VFIEN,VIEN,DFN,GBL,CNT,XREF,X
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET GBL=$$ROOT^DILFD(FNUM,,1)
+4 IF '$LENGTH(GBL)
SET @RET@(1)=$$ERR^BGOUTL(1069)
QUIT
+5 SET CNT=0
+6 SET DFN=+INP
+7 SET VFIEN=$PIECE(INP,U,2)
+8 SET VIEN=$PIECE(INP,U,3)
+9 IF VFIEN
Begin DoDot:1
+10 IF '$DATA(@GBL@(VFIEN,0))
SET @RET@(1)=$$ERR^BGOUTL(1070)
+11 IF '$TEST
DO GV1
End DoDot:1
+12 IF '$TEST
IF VIEN
Begin DoDot:1
+13 SET VFIEN=0
+14 FOR
SET VFIEN=$ORDER(@GBL@("AD",VIEN,VFIEN))
IF 'VFIEN
QUIT
DO GV1
End DoDot:1
+15 IF '$TEST
IF DFN
Begin DoDot:1
+16 ;P6
SET VFIEN=""
SET XREF=$$VFPTXREF
+17 FOR
SET VFIEN=$ORDER(@GBL@(XREF,DFN,VFIEN),-1)
IF 'VFIEN
QUIT
DO GV1
End DoDot:1
+18 IF '$TEST
SET @RET@(1)=$$ERR^BGOUTL(1008)
+19 QUIT
GV1 SET X=$$GETREC^BGOUTL(FNUM,VFIEN,FLDS)
+1 SET CNT=CNT+1
SET @RET@(CNT)=$PIECE(X,U)_U_$$ISLOCKED^BEHOENCX(+$PIECE($GET(@GBL@(VFIEN,0)),U,3))_U_$PIECE(X,U,2,9999)
+2 QUIT
+3 ; Fire V file update events
+4 ; FNUM = V File #
+5 ; VFIEN = V File IEN
+6 ; OPR = Operation (0 = add, 1 = edit, 2 = delete)
VFEVT(FNUM,VFIEN,OPR,X) ;EP
+1 NEW ID,GBL,DFN,VIEN,DATA
+2 SET GBL=$$ROOT^DILFD(FNUM,,1)
+3 IF '$LENGTH(GBL)
QUIT
+4 ;P6
IF '$GET(VFIEN)
QUIT
+5 SET ID=$PIECE(GBL,"AUPNV",2)
+6 IF '$DATA(X)
SET X=$GET(@GBL@(VFIEN,0))
+7 SET DFN=$PIECE(X,U,2)
SET VIEN=$PIECE(X,U,3)
SET DATA=VFIEN_U_$GET(CIA("UID"))_U_OPR_U_$PIECE(X,U)_U_VIEN
+8 IF DFN
DO BRDCAST^CIANBEVT("PCC."_DFN_"."_ID,DATA)
+9 IF VIEN
DO BRDCAST^CIANBEVT("VISIT."_VIEN_"."_ID,DATA)
+10 IF VIEN
DO VFMOD(VIEN)
+11 QUIT
+12 ; Update the visit modification date
VFMOD(AUPNVSIT) ;EP
+1 ;P6
IF $GET(DUZ("AG"))'="I"
QUIT
+2 NEW DIE,DA,DR,DIU,DIV
+3 DO MOD^AUPNVSIT
+4 QUIT
+5 ; Returns patient xref for V files
VFPTXREF() ;
+1 QUIT $SELECT($GET(DUZ("AG"))="I":"AC",1:"C")
+2 ; Find/create narrative text in narrative file, returning IEN
FNDNARR(NARR,CREATE) ;EP
+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 ;Return a subset list from the Apelon tool
SUBSET(RET,SUBSET) ; EP
+1 NEW OUT,IN,X
+2 SET RET=$$SNOTMP
+3 SET OUT="ARR"
+4 SET IN=SUBSET_"^36^1"
+5 SET X=$$SUBLST^BSTSAPI(.OUT,.IN)
+6 ;1 means success
+7 IF X>0
Begin DoDot:1
+8 MERGE @RET=@OUT
End DoDot:1
+9 QUIT
SNOTMP() KILL ^TMP("BGOSN",$JOB)
QUIT $NAME(^($JOB))
+1 ; Returns true if CSV is active
CSVACT(RTN) ;EP
+1 QUIT $SELECT(DUZ("AG")'="I":1,$$VERSION^XPDUTL("BCSV")="":0,'$LENGTH($GET(RTN)):1,1:$TEXT(+0^@RTN)'="")
AICD() ;EP
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
+2 ; Get the SNOMED data for a Concept ID
SNMDCONC(RET,CONCID) ; EP
+1 SET RET=$$CONC^BSTSAPI($GET(CONCID))
+2 QUIT
