- BMCCHSE ;IHS/OIT/FCJ - CHS EDIT INFORMATION
- ;;4.0;REFERRED CARE INFO SYSTEM;**8**;JAN 09, 2006;Build 101
- ;
- ;IHS.OIT.FCJ; NEW RTN IN PATCH 8 TO ALLOW ADDING CHS DENIAL REASONS
- ;
- ;
- DENR ;ENTRY POINT FROM BMCMOD
- ;
- TOF ;
- ;S BMCRIEN=113239
- S BMCOPTR="E"
- W @IOF,$$REPEAT^XLFSTR("=",79),!?30,"DENIAL REASONS EDIT",!,$$REPEAT^XLFSTR("=",79),!!,"PRIMARY DENIAL REASON: ",!
- PRIREAS ; PRIMARY REASON
- S X=$P($G(^BMCREF(BMCRIEN,11)),U,14),X1=$P($G(^BMCREF(BMCRIEN,61)),U,20)
- S BMCREA(1)=U_X_U_X1
- I X,$D(^ACHSDENS(X,0)) D
- .W !?10,"1. ",$P($G(^ACHSDENS(X,0)),U),!
- .W:X1 ?15,$P($G(^ACHSDENS(X,20,X1,0)),U)
- E W !!,*7,*7,"No Primary Denial Reason Has Been Entered" S BMCRED="",BMCOPTR="N",%=1,BMCR="Primary " D PRIM G TOF
- ;
- OTHREAS ; List other Denial Reasons
- I $D(^BMCREF(BMCRIEN,43)) D
- .S BMCREA=0,BMCCNT=2
- .F S BMCREA=$O(^BMCREF(BMCRIEN,43,BMCREA)) Q:BMCREA'?1.N D
- ..I BMCCNT=2 W !!,"OTHER DENIAL REASONS: ",!
- ..S BMCOTR=$P(^BMCREF(BMCRIEN,43,BMCREA,0),U),BMCROPT=$P(^(0),U,2)
- ..W !?10,BMCCNT,". ",$P($G(^ACHSDENS(BMCOTR,0)),U),!
- ..I BMCROPT W ?15,$P($G(^ACHSDENS(BMCOTR,20,BMCROPT,0)),U)
- ..S BMCREA(BMCCNT)=BMCREA_U_BMCOTR_U_BMCROPT
- ..S BMCCNT=BMCCNT+1
- ;
- EDIT ; EDIT REASONS
- ;
- S %=$$DIR^ACHS("FO","Enter Number Of Reason To Edit, 'A' To ADD Reason","","","",2)
- I (%="")!$D(DUOUT)!$D(DTOUT) D END Q
- S Y=+%,%=$S(+%=1:"PRIM","Aa"[%:"ADD",1:"OTHER")
- I (Y>BMCCNT)!((%="OTHER")&('$D(BMCREA(Y)))) W !,"Please enter a number from 1 to ",BMCCNT,"." G EDIT
- S BMCRED=+Y,BMCR=$S(%=1:"Primary",1:"Other ")
- D @%
- K BMCREA G TOF
- ;
- END ;
- K BMCREA,TMP,BMCCNT,BMCDEN
- K BMCENR,BMCENS,BMCOPTR,BMCOREO,BMCORNM,BMCOTR,BMCR,BMCRED,BMCREDT,CT,L
- Q
- ;
- PRIM ;
- D REA Q:$D(DUOUT)
- I X="@" W !!?5,"Must have a Primary Denial Reason." H 1 Q
- ;EDITING REASON THEN CHECK TO SEE IF DUPLICATE
- S (X,BMCOTR,BMCENR)=+Y
- S:BMCRED BMCORNM=$P(BMCREA(BMCRED),U)
- S BMCOREO=$P($G(^ACHSDENS(BMCOTR,0)),U)
- I BMCRED,BMCOTR'=$P(BMCREA(BMCRED),U,2) G PRIM:$$REASCK() S BMCENR=+Y
- Q:$D(DUOUT)
- D REAOPT
- I $D(Y),+Y<0 W !?5,"Denial Option did not change." H 1
- Q
- ;
- OTHER ;EDIT OTHER DENIAL REASON
- D REA Q:$D(DUOUT)
- S BMCORNM=$P(BMCREA(BMCRED),U)
- I X="@" D OTHSET Q ;THEN DELETE ENTRY...
- ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
- S (X,BMCOTR)=+Y
- S BMCOREO=$P($G(^ACHSDENS(BMCOTR,0)),U)
- I BMCOTR'=$P(BMCREA(BMCRED),U,2) G OTHER:$$REASCK() D OTHSET
- D OPTSET
- Q
- ;
- REA ; Denial Reason
- S X=0,CT=0,BMCREDT=""
- W !!?3,"Denial Reason List:"
- F S X=$O(^ACHSDENS(X)) Q:X'?1N.N D
- .I $D(^ACHSDENS(X,10)),$P(^ACHSDENS(X,10),U)>"" Q:$P(^ACHSDENS(X,10),U)<DT
- .S CT=CT+1 W !?5,CT,". ",$P(^ACHSDENS(X,0),U)
- .S BMCENS(CT)=X_U_$P(^ACHSDENS(X,0),U)
- .I BMCRED,X=$P($G(BMCREA(BMCRED)),U,2) S BMCREDT=CT
- I CT=0 W !,"No active Denial Reasons" S Y=-1 Q
- W !
- S BMCDEN="" I BMCRED>0 S BMCDEN=$P(^ACHSDENS($P(BMCREA(BMCRED),U,2),0),U)
- S DIR(0)="NO^1:"_CT
- S DIR("A")="Enter "_BMCR_" Denial Reason: "_BMCDEN
- S DIR("B")=BMCREDT
- D ^DIR
- Q:$D(DUOUT)
- S TMP=""
- I +Y>0 S TMP=BMCENS(Y)
- I BMCR["Other",+Y>0,Y'=BMCREDT,BMCCNT>1,%="OTHER" S X="@",BMCORNM=$P(BMCREA(BMCRED),U) D
- .D OTHSET
- .I $P(^BMCREF(BMCRIEN,43,0),U,4)<1 S $P(^(0),U,3,4)="1^1"
- S:TMP Y=TMP
- K DIR
- Q
- REASCK() ; --- Check if the Denial reason has already been entered.
- N X,X1,Y
- S (X,X1,Y)=0
- ;X1=TOTAL OPTIONS AVAILABLE;X=TOTAL REASON OR OPTIONS USED
- F S X=$O(^ACHSDENS(BMCOTR,20,X)) Q:X'?1N.N D
- .I $P(^ACHSDENS(BMCOTR,20,X,0),U,2)'="",$P(^(0),U,2)<DT Q
- .S X1=X1+1
- ;I X1=0 NO OPTION AVAILABLE JUST USING REASON
- I X1<2,BMCOTR=$P(^BMCREF(BMCRIEN,11),U,14),BMCOPTR="N" W !!,*7,*7,"DENIAL REASON/OPTIONS ALREADY SELECTED.",!! Q 1
- S X=0 I BMCOTR=$P(^BMCREF(BMCRIEN,11),U,14) S X=X+1
- I $D(^BMCREF(BMCRIEN,43)) S L=0 F S L=$O(^BMCREF(BMCRIEN,43,L)) Q:L'?1N.N D
- .I $P(^BMCREF(BMCRIEN,43,L,0),U)=BMCOTR S X=X+1
- I X<X1 Q Y
- W !!?5,"DENIAL REASON/OPTIONS ALREADY SELECTED. Need to select another.",!!
- Q 1
- ;
- REAOPT ; Primary Reason Option
- S Y=+$$DICOPT(BMCENR,"Primary ")
- I BMCOPTR="E" Q:+Y<0 G REAOPT:$$OPTCK("P")
- I +Y<0,(BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(ACHSDREA["Indian") W !,"Must select an option for this Denial Reason." G REAOPT
- S BMCROPT=+Y
- I Y>0 S DA=BMCRIEN,DIE="^BMCREF(" D PRMSET,PRMOSET
- Q
- PRMSET ;PRIMARY DENIAL REASON SET
- S DR="1114////"_BMCENR
- D ^DIE
- K DR
- Q
- PRMOSET ;
- S DR="6120///"_BMCROPT
- D ^DIE
- K DA,DIE,DR
- Q
- OTHSET ;SET OTHER DENIAL REASON - NODE 43
- S (DIC,DIE)="^BMCREF("_BMCRIEN_",43,"
- S DIC(0)="L",DA(1)=BMCRIEN,DA=BMCORNM
- S DR=".01_///"_X
- D ^DIE
- K DIE,DA,DR
- Q
- OPTSET ;SET OPTION FOR OTHER DENIAL REASON NODE 43
- ;ask for option
- S Y=$$DICOPT(BMCOTR,"Other ")
- I $D(DUOUT),BMCOPTR'="E" S X="@" D OTHSET Q
- I $D(DUOUT),BMCOPTR="E" D Q
- .;TEST FOR REASONS REQ AN OPTION, IF NONE SELECTED DELETE
- .I (BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(BMCOREO["Indian") D
- ..S BMCROPT=$P(^BMCREF(BMCRIEN,43,BMCORNM,0),U,2)
- ..I BMCROPT="" S X="@" D OTHSET Q
- G OPTSET:$$OPTCK("O") ;TEST FOR USING SAME OPT
- I +Y<0,(BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(BMCOREO["Indian") W !,"Must select an option for this Denial Reason." G OPTSET
- I +Y<0 Q
- S (DIC,DIE)="^BMCREF("_BMCRIEN_",43,"
- S DIC(0)="L",DA(1)=BMCRIEN,DA=BMCORNM
- S DR=".02///"_+Y
- D ^DIE
- S BMCROPT=$P(^BMCREF(BMCRIEN,43,BMCORNM,0),U,2)
- K DA,DIE
- Q
- ;
- DICOPT(X,R) ; --- Select Denial reason Option.
- I '$D(^ACHSDENS(X,20,0)) Q -1
- ;DISPLAY REA OPTIONS
- W !!?3,"Denial Reason Option list:"
- S X1=0,CT=0
- F S X1=$O(^ACHSDENS(X,20,X1)) Q:X1'?1N.N D
- .I $P(^ACHSDENS(X,20,X1,0),U,2)'="",$P(^(0),U,2)<DT Q
- .S CT=CT+1 W !?5,CT,". ",$P(^ACHSDENS(X,20,X1,0),U)
- .S BMCENO(CT)=X1_U_$P(^ACHSDENS(X,20,X1,0),U)
- I CT=0 W !,"No active Denial Reasons Options" S Y=-1 Q
- W !
- S DIR(0)="NO^1:"_CT
- S DIR("A")="Enter "_$G(R)_"Denial Reason Option "
- D ^DIR
- I +Y>0 S Y=BMCENO(Y)
- E S Y=-1
- K BMCENO
- Q +Y
- ;
- OPTCK(T) ; CHECK FOR OPTIONS ALREADY SELECTED ;ACHS*3.1*19 NEW SECTION
- S (X,X1)=0
- I T="O",$P(^BMCREF(BMCRIEN,11),U,14)=BMCOTR,$P(^BMCREF(BMCRIEN,61),U,20)=+Y W !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.",!! S X1=1 H 1 Q X1
- F S X=$O(^BMCREF(BMCRIEN,43,X)) Q:+X=0 D Q:X1
- .I BMCOPTR="E",X=BMCORNM Q
- .Q:$P($G(^BMCREF(BMCRIEN,43,X,0)),U)'=BMCOTR
- .I $P($G(^BMCREF(BMCRIEN,43,X,0)),U,2)=+Y W !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.....",!! S X1=1 H 1
- Q X1
- ;
- ADD ;ADD OTHER DENIAL REASON
- S BMCOPTR="N"
- D REA
- Q:+Y<1
- ;I BMCCNT=1 ADD PRIMARY REASON AND DO NOT NEED TO CHECK for duplicates
- I BMCR["Primary" S BMCENR=+Y D REAOPT Q
- ;I BMCCNT>1 ADD OTHER REASON AND NEED TO CHECK FOR DUPLICATES
- S BMCOTR=+Y
- S BMCOREO=$P($G(^ACHSDENS(BMCOTR,0)),U)
- G ADD:$$REASCK()
- ;I '$D(^BMCREF(BMCRIEN,43,0)) D
- S DIC="^BMCREF("_BMCRIEN_",43,"
- S DIC("P")=$P(^DD(90001,4300,0),U,2)
- S DIC(0)="L",DA(1)=BMCRIEN,X=BMCOTR
- S DIC("DR")=".01///"_X
- D FILE^BMCFMC S BMCORNM=+Y
- D:+Y>0 OPTSET
- Q
- ;
- BMCCHSE ;IHS/OIT/FCJ - CHS EDIT INFORMATION
- +1 ;;4.0;REFERRED CARE INFO SYSTEM;**8**;JAN 09, 2006;Build 101
- +2 ;
- +3 ;IHS.OIT.FCJ; NEW RTN IN PATCH 8 TO ALLOW ADDING CHS DENIAL REASONS
- +4 ;
- +5 ;
- DENR ;ENTRY POINT FROM BMCMOD
- +1 ;
- TOF ;
- +1 ;S BMCRIEN=113239
- +2 SET BMCOPTR="E"
- +3 WRITE @IOF,$$REPEAT^XLFSTR("=",79),!?30,"DENIAL REASONS EDIT",!,$$REPEAT^XLFSTR("=",79),!!,"PRIMARY DENIAL REASON: ",!
- PRIREAS ; PRIMARY REASON
- +1 SET X=$PIECE($GET(^BMCREF(BMCRIEN,11)),U,14)
- SET X1=$PIECE($GET(^BMCREF(BMCRIEN,61)),U,20)
- +2 SET BMCREA(1)=U_X_U_X1
- +3 IF X
- IF $DATA(^ACHSDENS(X,0))
- Begin DoDot:1
- +4 WRITE !?10,"1. ",$PIECE($GET(^ACHSDENS(X,0)),U),!
- +5 IF X1
- WRITE ?15,$PIECE($GET(^ACHSDENS(X,20,X1,0)),U)
- End DoDot:1
- +6 IF '$TEST
- WRITE !!,*7,*7,"No Primary Denial Reason Has Been Entered"
- SET BMCRED=""
- SET BMCOPTR="N"
- SET %=1
- SET BMCR="Primary "
- DO PRIM
- GOTO TOF
- +7 ;
- OTHREAS ; List other Denial Reasons
- +1 IF $DATA(^BMCREF(BMCRIEN,43))
- Begin DoDot:1
- +2 SET BMCREA=0
- SET BMCCNT=2
- +3 FOR
- SET BMCREA=$ORDER(^BMCREF(BMCRIEN,43,BMCREA))
- IF BMCREA'?1.N
- QUIT
- Begin DoDot:2
- +4 IF BMCCNT=2
- WRITE !!,"OTHER DENIAL REASONS: ",!
- +5 SET BMCOTR=$PIECE(^BMCREF(BMCRIEN,43,BMCREA,0),U)
- SET BMCROPT=$PIECE(^(0),U,2)
- +6 WRITE !?10,BMCCNT,". ",$PIECE($GET(^ACHSDENS(BMCOTR,0)),U),!
- +7 IF BMCROPT
- WRITE ?15,$PIECE($GET(^ACHSDENS(BMCOTR,20,BMCROPT,0)),U)
- +8 SET BMCREA(BMCCNT)=BMCREA_U_BMCOTR_U_BMCROPT
- +9 SET BMCCNT=BMCCNT+1
- End DoDot:2
- End DoDot:1
- +10 ;
- EDIT ; EDIT REASONS
- +1 ;
- +2 SET %=$$DIR^ACHS("FO","Enter Number Of Reason To Edit, 'A' To ADD Reason","","","",2)
- +3 IF (%="")!$DATA(DUOUT)!$DATA(DTOUT)
- DO END
- QUIT
- +4 SET Y=+%
- SET %=$SELECT(+%=1:"PRIM","Aa"[%:"ADD",1:"OTHER")
- +5 IF (Y>BMCCNT)!((%="OTHER")&('$DATA(BMCREA(Y))))
- WRITE !,"Please enter a number from 1 to ",BMCCNT,"."
- GOTO EDIT
- +6 SET BMCRED=+Y
- SET BMCR=$SELECT(%=1:"Primary",1:"Other ")
- +7 DO @%
- +8 KILL BMCREA
- GOTO TOF
- +9 ;
- END ;
- +1 KILL BMCREA,TMP,BMCCNT,BMCDEN
- +2 KILL BMCENR,BMCENS,BMCOPTR,BMCOREO,BMCORNM,BMCOTR,BMCR,BMCRED,BMCREDT,CT,L
- +3 QUIT
- +4 ;
- PRIM ;
- +1 DO REA
- IF $DATA(DUOUT)
- QUIT
- +2 IF X="@"
- WRITE !!?5,"Must have a Primary Denial Reason."
- HANG 1
- QUIT
- +3 ;EDITING REASON THEN CHECK TO SEE IF DUPLICATE
- +4 SET (X,BMCOTR,BMCENR)=+Y
- +5 IF BMCRED
- SET BMCORNM=$PIECE(BMCREA(BMCRED),U)
- +6 SET BMCOREO=$PIECE($GET(^ACHSDENS(BMCOTR,0)),U)
- +7 IF BMCRED
- IF BMCOTR'=$PIECE(BMCREA(BMCRED),U,2)
- IF $$REASCK()
- GOTO PRIM
- SET BMCENR=+Y
- +8 IF $DATA(DUOUT)
- QUIT
- +9 DO REAOPT
- +10 IF $DATA(Y)
- IF +Y<0
- WRITE !?5,"Denial Option did not change."
- HANG 1
- +11 QUIT
- +12 ;
- OTHER ;EDIT OTHER DENIAL REASON
- +1 DO REA
- IF $DATA(DUOUT)
- QUIT
- +2 SET BMCORNM=$PIECE(BMCREA(BMCRED),U)
- +3 ;THEN DELETE ENTRY...
- IF X="@"
- DO OTHSET
- QUIT
- +4 ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
- +5 SET (X,BMCOTR)=+Y
- +6 SET BMCOREO=$PIECE($GET(^ACHSDENS(BMCOTR,0)),U)
- +7 IF BMCOTR'=$PIECE(BMCREA(BMCRED),U,2)
- IF $$REASCK()
- GOTO OTHER
- DO OTHSET
- +8 DO OPTSET
- +9 QUIT
- +10 ;
- REA ; Denial Reason
- +1 SET X=0
- SET CT=0
- SET BMCREDT=""
- +2 WRITE !!?3,"Denial Reason List:"
- +3 FOR
- SET X=$ORDER(^ACHSDENS(X))
- IF X'?1N.N
- QUIT
- Begin DoDot:1
- +4 IF $DATA(^ACHSDENS(X,10))
- IF $PIECE(^ACHSDENS(X,10),U)>""
- IF $PIECE(^ACHSDENS(X,10),U)<DT
- QUIT
- +5 SET CT=CT+1
- WRITE !?5,CT,". ",$PIECE(^ACHSDENS(X,0),U)
- +6 SET BMCENS(CT)=X_U_$PIECE(^ACHSDENS(X,0),U)
- +7 IF BMCRED
- IF X=$PIECE($GET(BMCREA(BMCRED)),U,2)
- SET BMCREDT=CT
- End DoDot:1
- +8 IF CT=0
- WRITE !,"No active Denial Reasons"
- SET Y=-1
- QUIT
- +9 WRITE !
- +10 SET BMCDEN=""
- IF BMCRED>0
- SET BMCDEN=$PIECE(^ACHSDENS($PIECE(BMCREA(BMCRED),U,2),0),U)
- +11 SET DIR(0)="NO^1:"_CT
- +12 SET DIR("A")="Enter "_BMCR_" Denial Reason: "_BMCDEN
- +13 SET DIR("B")=BMCREDT
- +14 DO ^DIR
- +15 IF $DATA(DUOUT)
- QUIT
- +16 SET TMP=""
- +17 IF +Y>0
- SET TMP=BMCENS(Y)
- +18 IF BMCR["Other"
- IF +Y>0
- IF Y'=BMCREDT
- IF BMCCNT>1
- IF %="OTHER"
- SET X="@"
- SET BMCORNM=$PIECE(BMCREA(BMCRED),U)
- Begin DoDot:1
- +19 DO OTHSET
- +20 IF $PIECE(^BMCREF(BMCRIEN,43,0),U,4)<1
- SET $PIECE(^(0),U,3,4)="1^1"
- End DoDot:1
- +21 IF TMP
- SET Y=TMP
- +22 KILL DIR
- +23 QUIT
- REASCK() ; --- Check if the Denial reason has already been entered.
- +1 NEW X,X1,Y
- +2 SET (X,X1,Y)=0
- +3 ;X1=TOTAL OPTIONS AVAILABLE;X=TOTAL REASON OR OPTIONS USED
- +4 FOR
- SET X=$ORDER(^ACHSDENS(BMCOTR,20,X))
- IF X'?1N.N
- QUIT
- Begin DoDot:1
- +5 IF $PIECE(^ACHSDENS(BMCOTR,20,X,0),U,2)'=""
- IF $PIECE(^(0),U,2)<DT
- QUIT
- +6 SET X1=X1+1
- End DoDot:1
- +7 ;I X1=0 NO OPTION AVAILABLE JUST USING REASON
- +8 IF X1<2
- IF BMCOTR=$PIECE(^BMCREF(BMCRIEN,11),U,14)
- IF BMCOPTR="N"
- WRITE !!,*7,*7,"DENIAL REASON/OPTIONS ALREADY SELECTED.",!!
- QUIT 1
- +9 SET X=0
- IF BMCOTR=$PIECE(^BMCREF(BMCRIEN,11),U,14)
- SET X=X+1
- +10 IF $DATA(^BMCREF(BMCRIEN,43))
- SET L=0
- FOR
- SET L=$ORDER(^BMCREF(BMCRIEN,43,L))
- IF L'?1N.N
- QUIT
- Begin DoDot:1
- +11 IF $PIECE(^BMCREF(BMCRIEN,43,L,0),U)=BMCOTR
- SET X=X+1
- End DoDot:1
- +12 IF X<X1
- QUIT Y
- +13 WRITE !!?5,"DENIAL REASON/OPTIONS ALREADY SELECTED. Need to select another.",!!
- +14 QUIT 1
- +15 ;
- REAOPT ; Primary Reason Option
- +1 SET Y=+$$DICOPT(BMCENR,"Primary ")
- +2 IF BMCOPTR="E"
- IF +Y<0
- QUIT
- IF $$OPTCK("P")
- GOTO REAOPT
- +3 IF +Y<0
- IF (BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(ACHSDREA["Indian")
- WRITE !,"Must select an option for this Denial Reason."
- GOTO REAOPT
- +4 SET BMCROPT=+Y
- +5 IF Y>0
- SET DA=BMCRIEN
- SET DIE="^BMCREF("
- DO PRMSET
- DO PRMOSET
- +6 QUIT
- PRMSET ;PRIMARY DENIAL REASON SET
- +1 SET DR="1114////"_BMCENR
- +2 DO ^DIE
- +3 KILL DR
- +4 QUIT
- PRMOSET ;
- +1 SET DR="6120///"_BMCROPT
- +2 DO ^DIE
- +3 KILL DA,DIE,DR
- +4 QUIT
- OTHSET ;SET OTHER DENIAL REASON - NODE 43
- +1 SET (DIC,DIE)="^BMCREF("_BMCRIEN_",43,"
- +2 SET DIC(0)="L"
- SET DA(1)=BMCRIEN
- SET DA=BMCORNM
- +3 SET DR=".01_///"_X
- +4 DO ^DIE
- +5 KILL DIE,DA,DR
- +6 QUIT
- OPTSET ;SET OPTION FOR OTHER DENIAL REASON NODE 43
- +1 ;ask for option
- +2 SET Y=$$DICOPT(BMCOTR,"Other ")
- +3 IF $DATA(DUOUT)
- IF BMCOPTR'="E"
- SET X="@"
- DO OTHSET
- QUIT
- +4 IF $DATA(DUOUT)
- IF BMCOPTR="E"
- Begin DoDot:1
- +5 ;TEST FOR REASONS REQ AN OPTION, IF NONE SELECTED DELETE
- +6 IF (BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(BMCOREO["Indian")
- Begin DoDot:2
- +7 SET BMCROPT=$PIECE(^BMCREF(BMCRIEN,43,BMCORNM,0),U,2)
- +8 IF BMCROPT=""
- SET X="@"
- DO OTHSET
- QUIT
- End DoDot:2
- End DoDot:1
- QUIT
- +9 ;TEST FOR USING SAME OPT
- IF $$OPTCK("O")
- GOTO OPTSET
- +10 IF +Y<0
- IF (BMCOREO["Residency")!(BMCOREO["Notification")!(BMCOREO["Alternate")!(BMCOREO["Medical")!(BMCOREO["Indian")
- WRITE !,"Must select an option for this Denial Reason."
- GOTO OPTSET
- +11 IF +Y<0
- QUIT
- +12 SET (DIC,DIE)="^BMCREF("_BMCRIEN_",43,"
- +13 SET DIC(0)="L"
- SET DA(1)=BMCRIEN
- SET DA=BMCORNM
- +14 SET DR=".02///"_+Y
- +15 DO ^DIE
- +16 SET BMCROPT=$PIECE(^BMCREF(BMCRIEN,43,BMCORNM,0),U,2)
- +17 KILL DA,DIE
- +18 QUIT
- +19 ;
- DICOPT(X,R) ; --- Select Denial reason Option.
- +1 IF '$DATA(^ACHSDENS(X,20,0))
- QUIT -1
- +2 ;DISPLAY REA OPTIONS
- +3 WRITE !!?3,"Denial Reason Option list:"
- +4 SET X1=0
- SET CT=0
- +5 FOR
- SET X1=$ORDER(^ACHSDENS(X,20,X1))
- IF X1'?1N.N
- QUIT
- Begin DoDot:1
- +6 IF $PIECE(^ACHSDENS(X,20,X1,0),U,2)'=""
- IF $PIECE(^(0),U,2)<DT
- QUIT
- +7 SET CT=CT+1
- WRITE !?5,CT,". ",$PIECE(^ACHSDENS(X,20,X1,0),U)
- +8 SET BMCENO(CT)=X1_U_$PIECE(^ACHSDENS(X,20,X1,0),U)
- End DoDot:1
- +9 IF CT=0
- WRITE !,"No active Denial Reasons Options"
- SET Y=-1
- QUIT
- +10 WRITE !
- +11 SET DIR(0)="NO^1:"_CT
- +12 SET DIR("A")="Enter "_$GET(R)_"Denial Reason Option "
- +13 DO ^DIR
- +14 IF +Y>0
- SET Y=BMCENO(Y)
- +15 IF '$TEST
- SET Y=-1
- +16 KILL BMCENO
- +17 QUIT +Y
- +18 ;
- OPTCK(T) ; CHECK FOR OPTIONS ALREADY SELECTED ;ACHS*3.1*19 NEW SECTION
- +1 SET (X,X1)=0
- +2 IF T="O"
- IF $PIECE(^BMCREF(BMCRIEN,11),U,14)=BMCOTR
- IF $PIECE(^BMCREF(BMCRIEN,61),U,20)=+Y
- WRITE !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.",!!
- SET X1=1
- HANG 1
- QUIT X1
- +3 FOR
- SET X=$ORDER(^BMCREF(BMCRIEN,43,X))
- IF +X=0
- QUIT
- Begin DoDot:1
- +4 IF BMCOPTR="E"
- IF X=BMCORNM
- QUIT
- +5 IF $PIECE($GET(^BMCREF(BMCRIEN,43,X,0)),U)'=BMCOTR
- QUIT
- +6 IF $PIECE($GET(^BMCREF(BMCRIEN,43,X,0)),U,2)=+Y
- WRITE !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.....",!!
- SET X1=1
- HANG 1
- End DoDot:1
- IF X1
- QUIT
- +7 QUIT X1
- +8 ;
- ADD ;ADD OTHER DENIAL REASON
- +1 SET BMCOPTR="N"
- +2 DO REA
- +3 IF +Y<1
- QUIT
- +4 ;I BMCCNT=1 ADD PRIMARY REASON AND DO NOT NEED TO CHECK for duplicates
- +5 IF BMCR["Primary"
- SET BMCENR=+Y
- DO REAOPT
- QUIT
- +6 ;I BMCCNT>1 ADD OTHER REASON AND NEED TO CHECK FOR DUPLICATES
- +7 SET BMCOTR=+Y
- +8 SET BMCOREO=$PIECE($GET(^ACHSDENS(BMCOTR,0)),U)
- +9 IF $$REASCK()
- GOTO ADD
- +10 ;I '$D(^BMCREF(BMCRIEN,43,0)) D
- +11 SET DIC="^BMCREF("_BMCRIEN_",43,"
- +12 SET DIC("P")=$PIECE(^DD(90001,4300,0),U,2)
- +13 SET DIC(0)="L"
- SET DA(1)=BMCRIEN
- SET X=BMCOTR
- +14 SET DIC("DR")=".01///"_X
- +15 DO FILE^BMCFMC
- SET BMCORNM=+Y
- +16 IF +Y>0
- DO OPTSET
- +17 QUIT
- +18 ;