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

BGOUTL2.m

Go to the documentation of this file. 
  1. 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
  1.  ; Add refusals to output stream
  1.  ;  R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
  1.  ;  Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
  1.  ;  Added AICD lookup
  1. REFGET(RET,DFN,FNUM,CNT) ;EP
  1.  N TYPE,VDT,RIEN,REC,TYPNM,DATE,REASON,COMMENT,PRV,PRVNM
  1.  S TYPE=0,CNT=+$G(CNT)
  1.  S:$G(RET)="" RET=$$TMPGBL^BGOUTL
  1.  F  S TYPE=$O(^AUPNPREF("AA",DFN,FNUM,TYPE)) Q:'TYPE  D
  1.  .S VDT=0
  1.  .F  S VDT=$O(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT)) Q:'VDT  D
  1.  ..S RIEN=0
  1.  ..F  S RIEN=$O(^AUPNPREF("AA",DFN,FNUM,TYPE,VDT,RIEN)) Q:'RIEN  D
  1.  ...S CNT=CNT+1,@RET@(CNT)=$$REFGET1(RIEN)
  1.  Q
  1.  ; Return data for a specified refusal
  1.  ;  R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
  1.  ;  Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
  1. REFGET1(RIEN) ;EP
  1.  N REC,PRV,COMMENT,TYPE,TYPENM,REASON,DATE,PRVNM,FNUM,ITEM,ITEMNM,ARR,IN,OUT,X,SNTXT
  1.  S REC=$G(^AUPNPREF(RIEN,0)),PRV=$P($G(^(12)),U,4),COMMENT=$P($G(^(11)),U)
  1.  Q:REC=""
  1.  S SNTXT=""
  1.  S TYPE=+REC
  1.  S TYPENM=$P($G(^AUTTREFT(TYPE,0)),U)
  1.  S DATE=$$FMTDATE^BGOUTL($P(REC,U,3))
  1.  S ITEMNM=$P(REC,U,4)
  1.  ;IHS/MSC/MGH Patch 13
  1.  I TYPENM="SNOMED" D
  1.  .S ITEM=$P($G(^AUPNPREF(RIEN,13)),U,1)
  1.  .S X=$$CONC^BSTSAPI(ITEM_"^^^1")
  1.  .S ITEMNM=$P(X,U,4)
  1.  E  D
  1.  .S FNUM=$P(REC,U,5)
  1.  .S ITEM=$P(REC,U,6)
  1.  .S:ITEMNM="" ITEMNM=$$GET1^DIQ(FNUM,ITEM,.01)
  1.  S REASON=$$EXTERNAL^DILFD(9000022,.07,,$P(REC,U,7))
  1.  ;IHS/MSC/MGH patch 13
  1.  S CT=$P($G(^AUPNPREF(RIEN,1)),U,1)
  1.  I CT'="" D
  1.  .;S IN=CT_"^^^1"
  1.  .;S OUT="ARR"
  1.  .;S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
  1.  .;I X>0 D
  1.  .;.S SNTXT=@OUT@(1,"PRE","TRM")
  1.  .S X=$$CONC^BSTSAPI(CT_"^^^1")
  1.  .S SNTXT=$P(X,U,4)
  1.  S PRVNM=$S(PRV:$$GET1^DIQ(200,PRV,.01),1:"")
  1.  I TYPENM="EDUCATION TOPICS" D
  1.  .N TXT,SNO,IN,X,TOPTYP
  1.  .Q:'+ITEM
  1.  .I $P($G(^AUTTEDT(ITEM,0)),U,12)'="" D
  1.  ..S TXT=""
  1.  ..S SNO=$P($G(^AUTTEDT(ITEM,0)),U,12)
  1.  ..S IN=SNO_U_36_U_U_1
  1.  ..S X=$$CONC^BSTSAPI(IN)
  1.  ..S TXT=$P(X,U,4)
  1.  ..S TOPTYP=$P($P($G(^AUTTEDT(ITEM,0)),U,1),"-",2)
  1.  ..S ITEMNM=TXT_"-"_TOPTYP
  1.  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
  1.  ; Store a patient refusal (using visit IEN)
  1. REFSET(VIEN,ITEM,TYPE,RSN,CMNT,PRV,CT) ;EP
  1.  N X,RIEN
  1.  S RIEN=""
  1.  S X=$G(^AUPNVSIT(VIEN,0))
  1.  ;Q $$REFSET2($P(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,IEN,CT)
  1.  Q $$REFSET2($P(X,U,5),X\1,ITEM,TYPE,RSN,.CMNT,.PRV,RIEN,.CT)  ;2013-10-02 DKA P13 Correct <UNDEFINED> error
  1.  ; Store a patient refusal (alternate)
  1. REFSET2(DFN,DAT,ITEM,TYPE,RSN,CMNT,PRV,RIEN,CT) ;EP
  1.  N FDA,ERR,FNUM,RET,IENX,OPR,ZN,CPT,IN,OUT,X,ARR,SNO
  1.  S CT=$G(CT),RIEN=$G(RIEN)
  1.  S CPT=$$FIND1^DIC(9999999.73,,"X","CPT")  ;Patch 10 IHS/MSC/MGH
  1.  S SNO=$$FIND1^DIC(9999999.73,,"X","SNOMED") ;Patch 13
  1.  S TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
  1.  Q:'TYPE $$ERR^BGOUTL(1067)
  1.  S FNUM=$P(^AUTTREFT(TYPE,0),U,2),OPR=1
  1.  S:'$G(RIEN) RIEN=$O(^AUPNPREF("AA",DFN,FNUM,ITEM,9999999-DAT,0))
  1.  ;I "@"[RSN Q:'RIEN  S TYPE="@",OPR=2
  1.  I "@"[RSN,RIEN S TYPE="@",OPR=2
  1.  S:'RIEN RIEN="+1",OPR=0
  1.  S:OPR=2 ZN=$G(^AUPNPREF(RIEN,0))
  1.  S FDA=$NA(FDA(9000022,RIEN_","))
  1.  S @FDA@(.01)="`"_TYPE
  1.  S:'OPR @FDA@(.02)="`"_DFN
  1.  S @FDA@(.03)=DAT
  1.  S @FDA@(.08)=DAT
  1.  ;IHS/MSC/MGH Added storing narrative for CPT codes Patch 10
  1.  I TYPE=CPT S @FDA@(.04)=$E($$GET1^DIQ(FNUM,ITEM,2),1,80)
  1.  E  D
  1.  .I TYPE=SNO D
  1.  ..S @FDA@(1301)=ITEM
  1.  ..S @FDA@(.06)=ITEM
  1.  ..K ARR
  1.  ..S IN=ITEM_"^^^1"
  1.  ..S OUT="ARR"
  1.  ..S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
  1.  ..I X>0 D
  1.  ...S @FDA@(1302)=ARR(1,"PRE","DSC")
  1.  ...S @FDA@(.04)=ARR(1,"PRE","TRM")
  1.  ..;END patch 13 mod
  1.  .E  S @FDA@(.04)=$E($$GET1^DIQ(FNUM,ITEM,.01),1,80)
  1.  S @FDA@(.05)=FNUM
  1.  S @FDA@(.06)=ITEM
  1.  S @FDA@(.07)=RSN
  1.  ;IHS/MSC/MGH Patch 13 Added for reason
  1.  K ARR
  1.  I CT'="" D
  1.  .S IN=CT_"^^^1^"
  1.  .S OUT="ARR"
  1.  .S @FDA@(1.01)=CT
  1.  .S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
  1.  .I X>0 D
  1.  ..S @FDA@(1.02)=ARR(1,"PRE","DSC")
  1.  .;END patch 13 mod
  1.  S:$D(CMNT) @FDA@(1101)=CMNT
  1.  S:'$G(PRV) PRV=DUZ
  1.  S @FDA@(1204)="`"_PRV
  1.  ;IHS/MSC/MGH new fields patch 11
  1.  I $E(RIEN)="+" D
  1.  .S @FDA@(1216)="N"
  1.  .S @FDA@(1217)="`"_DUZ
  1.  S @FDA@(1218)="N"
  1.  S @FDA@(1219)="`"_DUZ
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"E@",.IENX)
  1.  S:$E(RIEN)="+" RIEN=$G(IENX(1))
  1.  D:'RET REFEVT(RIEN,OPR,.ZN)
  1.  Q RET
  1.  ; Delete a refusal
  1. REFDEL(IEN) ;EP
  1.  N RET,X
  1.  S X=$G(^AUPNPREF(IEN,0))
  1.  Q:'$L(X) ""
  1.  S RET=$$DELETE^BGOUTL("^AUPNPREF(",IEN)
  1.  D:'RET REFEVT(IEN,2,X)
  1.  Q RET
  1.  ; Delete a refusal (alternate)
  1. REFDEL2(VIEN,ITEM,TYPE) ;EP
  1.  N X,FNUM
  1.  S TYPE=$$FIND1^DIC(9999999.73,,"X",TYPE)
  1.  Q:'TYPE $$ERR^BGOUTL(1067)
  1.  S FNUM=$P(^AUTTREFT(TYPE,0),U,2)
  1.  S X=$G(^AUPNVSIT(VIEN,0))
  1.  Q $$REFDEL(+$O(^AUPNPREF("AA",+$P(X,U,5),FNUM,ITEM,9999999-(X\1),0)))
  1.  ; Broadcast a refusal event
  1. REFEVT(IEN,OPR,X) ;EP
  1.  N DFN,TYPE
  1.  S:'$D(X) X=$G(^AUPNPREF(IEN,0))
  1.  S DFN=$P(X,U,2)
  1.  Q:'DFN
  1.  S TYPE=$P($G(^AUTTREFT(+X,0)),U)
  1.  D BRDCAST^CIANBEVT("REFUSAL."_DFN_"."_TYPE,IEN_U_$G(CIA("UID"))_U_OPR)
  1.  Q
  1.  ; Returns true if a refusal is locked against editing
  1. REFLCK(IEN) ;EP
  1.  N DAT,DAYS
  1.  S DAT=+$P($G(^AUPNPREF(IEN,0)),U,3)
  1.  S DAYS=$$GET^XPAR("ALL","BEHOENCX VISIT LOCKED")
  1.  Q $S('DAT:-1,1:$$FMDIFF^XLFDT(DT,DAT)>$S(DAYS<1:1,1:DAYS))
  1.  ; Check for duplicate V File type in a visit
  1.  ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
  1. 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)
  1.  D VFFND(.RET,FNUM,TYPE,VIEN,.EIEFLD)
  1.  S:RET RET=$$ERR^BGOUTL(1068,ENTITY)_U_RET
  1.  Q
  1.  ; Locate a V File entry
  1.  ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
  1. VFFND(RET,FNUM,TYPE,VIEN,EIEFLD) ;EP
  1.  N X,GBL
  1.  S GBL=$$ROOT^DILFD(FNUM,,1)
  1.  I '$L(GBL) S RET=$$ERR^BGOUTL(1069) Q
  1.  S X=0,RET=""
  1.  F  S X=$O(@GBL@("AD",VIEN,X)) Q:'X  D  Q:RET
  1.  .I FNUM=9000010.51,$G(EIEFLD)=1.01,$P($G(@GBL@(X,1)),U) Q  ; DKA 7/12/13 Ignore Entered in Error entries
  1.  .S:$P($G(@GBL@(X,0)),U)=TYPE RET=X
  1.  Q
  1.  ; Create root V File entry
  1.  ;  FNUM = File number
  1.  ;  TYPE = Entry type (.01 of V File)
  1.  ;  VIEN = Visit IEN
  1.  ;  NAME = Name of entity (if checking for dups)
  1.  ;  FLDS = Additional field values (optional)
  1.  ; .RET  = IEN of new entry or -1^error text
  1.  ; DKA 7/12/13 Patch 13 - Add EIEFLD to specify Entered in Error field
  1. VFNEW(RET,FNUM,TYPE,VIEN,NAME,FLDS,EIEFLD) ;EP
  1.  N FDA,IEN,V0,CAT,APCDVSIT,PXCEVIEN
  1.  S V0=$G(^AUPNVSIT(VIEN,0)),CAT=$P(V0,U,7)
  1.  ;I $L($G(NAME)),CAT'="H" D VFCHK(.RET,FNUM,TYPE,NAME,VIEN) Q:RET
  1.  I $L($G(NAME)),CAT'="H" D VFCHK(.RET,FNUM,TYPE,NAME,VIEN,.EIEFLD) Q:RET
  1.  I $G(DUZ("AG"))="I" S APCDVSIT=VIEN
  1.  E  S PXCEVIEN=VIEN
  1.  S FDA=$NA(FDA(FNUM,"+1,"))
  1.  S @FDA@(.01)=TYPE
  1.  S @FDA@(.02)=$P(V0,U,5)
  1.  S @FDA@(.03)=VIEN
  1.  S:$D(^DD(FNUM,1201,0)) @FDA@(1201)=$S(CAT="H":$$NOW^XLFDT,1:+V0)
  1.  M @FDA=FLDS
  1.  S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
  1.  S:'RET RET=IEN(1)
  1.  Q
  1.  ; Delete V File entry
  1. VFDEL(RET,FNUM,VFIEN) ;EP
  1.  N VIEN,GBL,X
  1.  S GBL=$$ROOT^DILFD(FNUM,,1),RET=""
  1.  Q:'VFIEN
  1.  I '$L(GBL) S RET=$$ERR^BGOUTL(1069) Q
  1.  S X=$G(@GBL@(VFIEN,0))
  1.  S VIEN=$P(X,U,3)
  1.  Q:'VIEN
  1.  S RET=$$CHKVISIT^BGOUTL(VIEN)
  1.  S:'RET RET=$$DELETE^BGOUTL(FNUM,VFIEN)
  1.  D:'RET VFEVT(FNUM,VFIEN,2,X)
  1.  Q
  1.  ; Fetch V File entries
  1.  ;  INP = Patient IEN (for entries associated with a patient) [1] ^
  1.  ;        V File IEN (for single entry) [2] ^
  1.  ;        Visit IEN (for entries associated with a visit) [3]
  1.  ;  FNUM= V File #
  1.  ;  FLDS= Fields to retrieve
  1. VFGET(RET,INP,FNUM,FLDS) ;EP
  1.  N VFIEN,VIEN,DFN,GBL,CNT,XREF,X
  1.  S RET=$$TMPGBL^BGOUTL
  1.  S GBL=$$ROOT^DILFD(FNUM,,1)
  1.  I '$L(GBL) S @RET@(1)=$$ERR^BGOUTL(1069) Q
  1.  S CNT=0
  1.  S DFN=+INP
  1.  S VFIEN=$P(INP,U,2)
  1.  S VIEN=$P(INP,U,3)
  1.  I VFIEN D
  1.  .I '$D(@GBL@(VFIEN,0)) S @RET@(1)=$$ERR^BGOUTL(1070)
  1.  .E  D GV1
  1.  E  I VIEN D
  1.  .S VFIEN=0
  1.  .F  S VFIEN=$O(@GBL@("AD",VIEN,VFIEN)) Q:'VFIEN  D GV1
  1.  E  I DFN D
  1.  .S VFIEN="",XREF=$$VFPTXREF   ;P6
  1.  .F  S VFIEN=$O(@GBL@(XREF,DFN,VFIEN),-1) Q:'VFIEN  D GV1
  1.  E  S @RET@(1)=$$ERR^BGOUTL(1008)
  1.  Q
  1. GV1 S X=$$GETREC^BGOUTL(FNUM,VFIEN,FLDS)
  1.  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)
  1.  Q
  1.  ; Fire V file update events
  1.  ;  FNUM  = V File #
  1.  ;  VFIEN = V File IEN
  1.  ;  OPR   = Operation (0 = add, 1 = edit, 2 = delete)
  1. VFEVT(FNUM,VFIEN,OPR,X) ;EP
  1.  N ID,GBL,DFN,VIEN,DATA
  1.  S GBL=$$ROOT^DILFD(FNUM,,1)
  1.  Q:'$L(GBL)
  1.  Q:'$G(VFIEN)  ;P6
  1.  S ID=$P(GBL,"AUPNV",2)
  1.  S:'$D(X) X=$G(@GBL@(VFIEN,0))
  1.  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
  1.  D:DFN BRDCAST^CIANBEVT("PCC."_DFN_"."_ID,DATA)
  1.  D:VIEN BRDCAST^CIANBEVT("VISIT."_VIEN_"."_ID,DATA)
  1.  D:VIEN VFMOD(VIEN)
  1.  Q
  1.  ; Update the visit modification date
  1. VFMOD(AUPNVSIT) ;EP
  1.  Q:$G(DUZ("AG"))'="I"  ;P6
  1.  N DIE,DA,DR,DIU,DIV
  1.  D MOD^AUPNVSIT
  1.  Q
  1.  ; Returns patient xref for V files
  1. VFPTXREF() ;
  1.  Q $S($G(DUZ("AG"))="I":"AC",1:"C")
  1.  ; Find/create narrative text in narrative file, returning IEN
  1. FNDNARR(NARR,CREATE) ;EP
  1.  N IEN,FDA,TRC,RET
  1.  Q:'$L(NARR) ""
  1.  S IEN=0,TRC=$E(NARR,1,30),NARR=$E(NARR,1,160),CREATE=$G(CREATE,1)
  1.  F  S IEN=$O(^AUTNPOV("B",TRC,IEN)) Q:'IEN  Q:$P($G(^AUTNPOV(IEN,0)),U)=NARR
  1.  Q:IEN!'CREATE IEN
  1.  S FDA(9999999.27,"+1,",.01)=NARR
  1.  S RET=$$UPDATE^BGOUTL(.FDA,"E",.IEN)
  1.  Q $S(RET:RET,1:IEN(1))
  1.  ;Return a subset list from the Apelon tool
  1. SUBSET(RET,SUBSET) ; EP
  1.  N OUT,IN,X
  1.  S RET=$$SNOTMP
  1.  S OUT="ARR"
  1.  S IN=SUBSET_"^36^1"
  1.  S X=$$SUBLST^BSTSAPI(.OUT,.IN)
  1.  ;1  means success
  1.  I X>0 D
  1.  .M @RET=@OUT
  1.  Q
  1. SNOTMP() K ^TMP("BGOSN",$J) Q $NA(^($J))
  1.  ; Returns true if CSV is active
  1. CSVACT(RTN) ;EP
  1.  Q $S(DUZ("AG")'="I":1,$$VERSION^XPDUTL("BCSV")="":0,'$L($G(RTN)):1,1:$T(+0^@RTN)'="")
  1. AICD() ;EP
  1.  Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
  1.  ; Get the SNOMED data for a Concept ID
  1. SNMDCONC(RET,CONCID) ; EP
  1.  S RET=$$CONC^BSTSAPI($G(CONCID))
  1.  Q