BGOREF.m

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