BGOREF ; IHS/BAO/TMD - Manage REFUSALS ;18-Apr-2014 12:29;DU
;;1.1;BGO COMPONENTS;**1,3,5,11,13**;Mar 20, 2007;Build 16
; Add/edit a refusal
; INP = Refusal IEN [1] ^ Refusal Type [2] ^ Item IEN [3] ^ Patient IEN [4] ^
; Refusal Date [5] ^ Comment [6] ^ Provider IEN [7] ^ Reason [8]
;Patch 5, changed mammogram code for bilateral mammogram
;Patch 13,changes for SNOMED
SET(RET,INP) ;EP
N DFN,REFIEN,REFTYP,ITEMIEN,REFDATE,COMMENT,REASON,PRV,HST,HIS,CT
S (CT,HIS)=""
S DFN=$P(INP,U,4)
I 'DFN S RET=$$ERR^BGOUTL(1050) Q
I '$D(^AUPNPAT(DFN,0)) S RET=$$ERR^BGOUTL(1001) Q
S REFIEN=+INP
S REFTYP=$P(INP,U,2)
S ITEMIEN=$P(INP,U,3)
S REFDATE=$P(INP,U,5)
S COMMENT=$P(INP,U,6)
S PRV=$P(INP,U,7)
S REASON=$P(INP,U,8)
I $L(REASON)>0 D
.;IHS/MSC/MGH Patch 11
.;S REASON=$$UPPER^BGOVPED2(REASON)
.;S REASON=$S(REASON="REFUSED SERVICE":"R",REASON="UNABLE TO SCREEN":"U",REASON="NOT MEDICALLY INDICATED":"N",REASON="NO RESPONSE TO FOLLOWUP":"F",REASON="PROVIDER DISCONTINUED":"P",1:"")
.;Patch 13 cfhanged reason to SNOMED
.S CT=$$GET1^DIQ(9999999.102,REASON,.01)
.S HIS=$$GET1^DIQ(9999999.102,REASON,.04,"I")
;S:REASON="" REASON="R"
S RET=$$REFSET2^BGOUTL2(DFN,REFDATE,ITEMIEN,REFTYP,HIS,COMMENT,PRV,REFIEN,CT)
Q
; Get refusal data
; INP = Patient IEN ^ Refusal IEN
; List of records in the format:
; 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]
GET(RET,INP) ;EP
N CNT,DFN,REFIEN
S RET=$$TMPGBL^BGOUTL
S DFN=+INP
S REFIEN=$P(INP,U,2)
I REFIEN S @RET@(1)=$$REFGET1^BGOUTL2(REFIEN)
E D
.S REFIEN="",CNT=0
.F S REFIEN=$O(^AUPNPREF("AC",DFN,REFIEN),-1) Q:'REFIEN D
..S CNT=CNT+1,@RET@(CNT)=$$REFGET1^BGOUTL2(REFIEN)
Q
; Delete a refusal
DEL(RET,REFIEN) ;EP
S RET=$$REFDEL^BGOUTL2(REFIEN)
Q
; Return IEN for pap smear/mammogram/ekg
REFLIST(RET,INP) ;EP
S INP=$$UP^XLFSTR(INP)
I INP="PAP SMEAR" S RET=$O(^LAB(60,"B","PAP SMEAR",0))
E I INP="MAMMOGRAM" S RET=$O(^RAMIS(71,"D",76056,0))
E I INP="EKG" S RET=$O(^AUTTDXPR("B","ECG SUMMARY",0))
E S RET=$$ERR^BGOUTL(1051,INP)
Q
;Return the list of SNOMED reasons for refusal
;Returns the list with the
;IEN [1] ^ TEXT [2]
GETREA(RET,TYPE) ;EP
N IEN,SCREEN,CNT
S RET=$$TMPGBL^BGOUTL
S TYPE=$$UP^XLFSTR(TYPE)
S CNT=0
I $G(TYPE)="" S TYPE="IMMUNIZATION"
S IEN=0 F S IEN=$O(^AUTTREFR(IEN)) Q:'+IEN D
.S SCREEN=$$GET1^DIQ(9999999.102,IEN,.06,"I")
.I TYPE="MEDICATION/DRUG"&(SCREEN=1!(SCREEN=3)) D ADD(IEN)
.E I SCREEN=2!(SCREEN=3) D ADD(IEN)
Q
ADD(IEN) ;Add to array
N IN,OUT,X,ARR,DESC,TXT
S CT=$$GET1^DIQ(9999999.102,IEN,.01)
S IN=CT_"^36^^1^"
S OUT="ARR"
S X=$$CNCLKP^BSTSAPI(.OUT,.IN)
I X>0 D
.S TXT=@OUT@(1,"PRE","TRM")
.S CNT=CNT+1
.S @RET@(CNT)=IEN_U_TXT
Q
BGOREF ; IHS/BAO/TMD - Manage REFUSALS ;18-Apr-2014 12:29;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,5,11,13**;Mar 20, 2007;Build 16
+2 ; Add/edit a refusal
+3 ; INP = Refusal IEN [1] ^ Refusal Type [2] ^ Item IEN [3] ^ Patient IEN [4] ^
+4 ; Refusal Date [5] ^ Comment [6] ^ Provider IEN [7] ^ Reason [8]
+5 ;Patch 5, changed mammogram code for bilateral mammogram
+6 ;Patch 13,changes for SNOMED
SET(RET,INP) ;EP
+1 NEW DFN,REFIEN,REFTYP,ITEMIEN,REFDATE,COMMENT,REASON,PRV,HST,HIS,CT
+2 SET (CT,HIS)=""
+3 SET DFN=$PIECE(INP,U,4)
+4 IF 'DFN
SET RET=$$ERR^BGOUTL(1050)
QUIT
+5 IF '$DATA(^AUPNPAT(DFN,0))
SET RET=$$ERR^BGOUTL(1001)
QUIT
+6 SET REFIEN=+INP
+7 SET REFTYP=$PIECE(INP,U,2)
+8 SET ITEMIEN=$PIECE(INP,U,3)
+9 SET REFDATE=$PIECE(INP,U,5)
+10 SET COMMENT=$PIECE(INP,U,6)
+11 SET PRV=$PIECE(INP,U,7)
+12 SET REASON=$PIECE(INP,U,8)
+13 IF $LENGTH(REASON)>0
Begin DoDot:1
+14 ;IHS/MSC/MGH Patch 11
+15 ;S REASON=$$UPPER^BGOVPED2(REASON)
+16 ;S REASON=$S(REASON="REFUSED SERVICE":"R",REASON="UNABLE TO SCREEN":"U",REASON="NOT MEDICALLY INDICATED":"N",REASON="NO RESPONSE TO FOLLOWUP":"F",REASON="PROVIDER DISCONTINUED":"P",1:"")
+17 ;Patch 13 cfhanged reason to SNOMED
+18 SET CT=$$GET1^DIQ(9999999.102,REASON,.01)
+19 SET HIS=$$GET1^DIQ(9999999.102,REASON,.04,"I")
End DoDot:1
+20 ;S:REASON="" REASON="R"
+21 SET RET=$$REFSET2^BGOUTL2(DFN,REFDATE,ITEMIEN,REFTYP,HIS,COMMENT,PRV,REFIEN,CT)
+22 QUIT
+23 ; Get refusal data
+24 ; INP = Patient IEN ^ Refusal IEN
+25 ; List of records in the format:
+26 ; R ^ Refusal IEN [2] ^ Type IEN [3] ^ Type Name [4] ^ Item IEN [5] ^ Item Name [6] ^ Provider IEN [7] ^
+27 ; Provider Name [8] ^ Date [9] ^ Locked [10] ^ Reason [11] ^ Comment [12]
GET(RET,INP) ;EP
+1 NEW CNT,DFN,REFIEN
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET DFN=+INP
+4 SET REFIEN=$PIECE(INP,U,2)
+5 IF REFIEN
SET @RET@(1)=$$REFGET1^BGOUTL2(REFIEN)
+6 IF '$TEST
Begin DoDot:1
+7 SET REFIEN=""
SET CNT=0
+8 FOR
SET REFIEN=$ORDER(^AUPNPREF("AC",DFN,REFIEN),-1)
IF 'REFIEN
QUIT
Begin DoDot:2
+9 SET CNT=CNT+1
SET @RET@(CNT)=$$REFGET1^BGOUTL2(REFIEN)
End DoDot:2
End DoDot:1
+10 QUIT
+11 ; Delete a refusal
DEL(RET,REFIEN) ;EP
+1 SET RET=$$REFDEL^BGOUTL2(REFIEN)
+2 QUIT
+3 ; Return IEN for pap smear/mammogram/ekg
REFLIST(RET,INP) ;EP
+1 SET INP=$$UP^XLFSTR(INP)
+2 IF INP="PAP SMEAR"
SET RET=$ORDER(^LAB(60,"B","PAP SMEAR",0))
+3 IF '$TEST
IF INP="MAMMOGRAM"
SET RET=$ORDER(^RAMIS(71,"D",76056,0))
+4 IF '$TEST
IF INP="EKG"
SET RET=$ORDER(^AUTTDXPR("B","ECG SUMMARY",0))
+5 IF '$TEST
SET RET=$$ERR^BGOUTL(1051,INP)
+6 QUIT
+7 ;Return the list of SNOMED reasons for refusal
+8 ;Returns the list with the
+9 ;IEN [1] ^ TEXT [2]
GETREA(RET,TYPE) ;EP
+1 NEW IEN,SCREEN,CNT
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET TYPE=$$UP^XLFSTR(TYPE)
+4 SET CNT=0
+5 IF $GET(TYPE)=""
SET TYPE="IMMUNIZATION"
+6 SET IEN=0
FOR
SET IEN=$ORDER(^AUTTREFR(IEN))
IF '+IEN
QUIT
Begin DoDot:1
+7 SET SCREEN=$$GET1^DIQ(9999999.102,IEN,.06,"I")
+8 IF TYPE="MEDICATION/DRUG"&(SCREEN=1!(SCREEN=3))
DO ADD(IEN)
+9 IF '$TEST
IF SCREEN=2!(SCREEN=3)
DO ADD(IEN)
End DoDot:1
+10 QUIT
ADD(IEN) ;Add to array
+1 NEW IN,OUT,X,ARR,DESC,TXT
+2 SET CT=$$GET1^DIQ(9999999.102,IEN,.01)
+3 SET IN=CT_"^36^^1^"
+4 SET OUT="ARR"
+5 SET X=$$CNCLKP^BSTSAPI(.OUT,.IN)
+6 IF X>0
Begin DoDot:1
+7 SET TXT=@OUT@(1,"PRE","TRM")
+8 SET CNT=CNT+1
+9 SET @RET@(CNT)=IEN_U_TXT
End DoDot:1
+10 QUIT
