ACHSDN4 ; IHS/ITSC/PMF - DENIAL EDIT - DENIAL REASONS ; [ 02/12/2002 10:26 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,18,19,21**;JUN 11, 2001;Build 43
;ACHS*3.1*19 Rewrote routine
;
N ALT,DAT,SS
;
TOF ;
S ACHDOPTR="E"
W @IOF,$$REPEAT^XLFSTR("=",79),!?30,"DENIAL REASONS EDIT",!,$$REPEAT^XLFSTR("=",79),!!,"PRIMARY DENIAL REASON: ",!
S X=$$DN^ACHS(250,1),X1=$$DN^ACHS(250,2)
I X,$D(^ACHSDENS(X,0)) D G OTHREAS
.W !?10,"1. ",$P($G(^ACHSDENS(X,0)),U),!
.W:X1 ?15,$P($G(^ACHSDENS(X,20,X1,0)),U)
.S ACHDREA(1)=U_X_U_X1
.I (($P($G(^ACHSDENS(X,20,X1,0)),U)["Eligible")!($P($G(^ACHSDENS(X,20,X1,0)),U)["Failure")),$D(^ACHSDEN(DUZ(2),"D",ACHSA,256)) D
..S R1=0 F S R1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1)) Q:R1'?1N.N D
...S R2=$P(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1,0),U)
...W !,?20,$P($G(^ACHSDENS(X,30,R2,0)),U)
W !!,*7,*7,"No Primary Denial Reason Has Been Entered, But is required" D PRIM
K ACHDREA G TOF
;
OTHREAS ; --- List other Denial Reasons
;I $D(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),U,4))>0 W !!,"OTHER DENIAL REASONS: ",!
S ACHDREA=0,ACHDCNT=1
F S ACHDREA=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA)) Q:ACHDREA'?1.N D
.I ACHDCNT=1 W !!,"OTHER DENIAL REASONS: ",!
.S ACHDCNT=ACHDCNT+1
.S ACHDOTR=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,0),U),ACHDROPT=$P(^(0),U,2)
.W !?10,ACHDCNT,". ",$P($G(^ACHSDENS(ACHDOTR,0)),U),!
.I ACHDROPT W ?15,$P($G(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)
.I (($P($G(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)["Eligible")!($P($G(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)["Failure")),$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4)) D
..S R1=0 F S R1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1)) Q:R1'?1N.N D
...S R2=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1,0),U)
...W !,?20,$P($G(^ACHSDENS(ACHDOTR,30,R2,0)),U)
.S ACHDREA(ACHDCNT)=ACHDREA_U_ACHDOTR_U_ACHDROPT
;
OTHR1 ;
;
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>ACHDCNT)!((%="OTHER")&('$D(ACHDREA(Y)))) W !,"Please enter a number from 1 to ",ACHDCNT,"." G OTHR1
S ACHDRED=+Y,ACHDR=$S(%="OTHER":"Other",1:"Primary")
D @%
G TOF
;
END ;
K ACHDREA,TMP
Q
;
PRIM ;
D REA
I X="@" W !!?5,"Must have a Primary Denial Reason." H 1 Q
;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
S (X,ACHDOTR,ACHDENR)=+Y
S ACHDORNM=$P(ACHDREA(ACHDRED),U)
S ACHDOREO=$P($G(^ACHSDENS(ACHDOTR,0)),U)
I ACHDOTR'=$P(ACHDREA(ACHDRED),U,2) G PRIM:$$REASCK^ACHSDN2() D PRMSET
Q:$D(DUOUT)
D REAOPT^ACHSDN2
I $D(Y),+Y<0 W !?5,"Denial Option did not change." H 1
Q
;
OTHER ;EDIT OTHER DENIAL REASON
D REA
S ACHDORNM=$P(ACHDREA(ACHDRED),U)
I X="@" D OTHSET Q ;THEN DELETE ENTRY...
;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
S (X,ACHDOTR)=+Y
S ACHDOREO=$P($G(^ACHSDENS(ACHDOTR,0)),U)
I ACHDOTR'=$P(ACHDREA(ACHDRED),U,2) G OTHER:$$REASCK^ACHSDN2() D OTHSET
D OPTSET
D OTHREA1^ACHSDN2
Q
REA ;
S X=0,CT=0
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 ACHDENS(CT)=X_U_$P(^ACHSDENS(X,0),U)
.I X=$P(ACHDREA(ACHDRED),U,2) S ACHDREDT=CT
I CT=0 W !,"No active Denial Reasons" S Y=-1 Q
W !
S DIR(0)="NO^1:"_CT
S DIR("A")="Enter "_ACHDR_" Denial Reason: "_$P(^ACHSDENS($P(ACHDREA(ACHDRED),U,2),0),U)
S DIR("B")=ACHDREDT
D ^DIR
;ACHS*3.1*21 CHANGED NXT LINE
;I +Y>0 S Y=ACHDENS(Y)
S TMP=""
I +Y>0 S TMP=ACHDENS(Y)
I ACHDR["Primary",+Y>0,Y'=ACHDREDT D PRMDEL
I ACHDR["Other",+Y>0,Y'=ACHDREDT,ACHDCNT>1 S X="@",ACHDORNM=$P(ACHDREA(ACHDRED),U) D
.D OTHSET
.I $P(^ACHSDEN(DUZ(2),"D",ACHSA,300,0),U,4)<1 S $P(^(0),U,3,4)="1^1"
S:TMP Y=TMP
K DIR
Q
PRMSET ;PRIMARY DENIAL REASON SET
S ACHDENR=+Y
;ACHS*3.1*10 4.22.04 IHS/ITSC/FCJ TEST FOR REF TO SET DENIAL REASON
I $G(ACHSREF) S ACHSREF(1114)=ACHDENR ;ACHS*3.1*10 4.22.04
S ACHSDREA=$P($G(^ACHSDENS(ACHDENR,0)),U) ;ACHS*3.1*18 NEW LINE
I '$$DIE^ACHSDN("250////"_ACHDENR) Q
I $D(Y) S DUOUT="" Q
Q
PRMDEL ;PRIM DEL OTHER TYPE ;ACHS*3.1*21 NEW SECTION
Q:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,256))
S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",256,"
S DR=".01_///@"
S L=0 F S L=$O(^ACHSDEN(DUZ(2),"D",ACHSA,256,L)) Q:L'?1N.N D
.S DA(2)=DUZ(2)
.S DA(1)=ACHSA
.S DA=L
.D ^DIE
K DIE,DA,DR
Q
OTHSET ;SET OTHER DENIAL REASON
S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
S DA(2)=DUZ(2)
S DA(1)=ACHSA
S DA=ACHDORNM
S DR=".01_///"_X
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","+") S DUOUT="" Q
D ^DIE
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","-") S DUOUT="" Q
K DIE,DA,DR
Q
OPTSET ;SET OPTION
D OTHREAO^ACHSDN2
Q
;
ADD ;ADD OTHER DENIAL REASON
W !!
D OTHREAS^ACHSDN2
Q
;
ACHSDN4 ; IHS/ITSC/PMF - DENIAL EDIT - DENIAL REASONS ; [ 02/12/2002 10:26 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,18,19,21**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*19 Rewrote routine
+3 ;
+4 NEW ALT,DAT,SS
+5 ;
TOF ;
+1 SET ACHDOPTR="E"
+2 WRITE @IOF,$$REPEAT^XLFSTR("=",79),!?30,"DENIAL REASONS EDIT",!,$$REPEAT^XLFSTR("=",79),!!,"PRIMARY DENIAL REASON: ",!
+3 SET X=$$DN^ACHS(250,1)
SET X1=$$DN^ACHS(250,2)
+4 IF X
IF $DATA(^ACHSDENS(X,0))
Begin DoDot:1
+5 WRITE !?10,"1. ",$PIECE($GET(^ACHSDENS(X,0)),U),!
+6 IF X1
WRITE ?15,$PIECE($GET(^ACHSDENS(X,20,X1,0)),U)
+7 SET ACHDREA(1)=U_X_U_X1
+8 IF (($PIECE($GET(^ACHSDENS(X,20,X1,0)),U)["Eligible")!($PIECE($GET(^ACHSDENS(X,20,X1,0)),U)["Failure"))
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,256))
Begin DoDot:2
+9 SET R1=0
FOR
SET R1=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1))
IF R1'?1N.N
QUIT
Begin DoDot:3
+10 SET R2=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1,0),U)
+11 WRITE !,?20,$PIECE($GET(^ACHSDENS(X,30,R2,0)),U)
End DoDot:3
End DoDot:2
End DoDot:1
GOTO OTHREAS
+12 WRITE !!,*7,*7,"No Primary Denial Reason Has Been Entered, But is required"
DO PRIM
+13 KILL ACHDREA
GOTO TOF
+14 ;
OTHREAS ; --- List other Denial Reasons
+1 ;I $D(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),U,4))>0 W !!,"OTHER DENIAL REASONS: ",!
+2 SET ACHDREA=0
SET ACHDCNT=1
+3 FOR
SET ACHDREA=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA))
IF ACHDREA'?1.N
QUIT
Begin DoDot:1
+4 IF ACHDCNT=1
WRITE !!,"OTHER DENIAL REASONS: ",!
+5 SET ACHDCNT=ACHDCNT+1
+6 SET ACHDOTR=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,0),U)
SET ACHDROPT=$PIECE(^(0),U,2)
+7 WRITE !?10,ACHDCNT,". ",$PIECE($GET(^ACHSDENS(ACHDOTR,0)),U),!
+8 IF ACHDROPT
WRITE ?15,$PIECE($GET(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)
+9 IF (($PIECE($GET(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)["Eligible")!($PIECE($GET(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)["Failure"))
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4))
Begin DoDot:2
+10 SET R1=0
FOR
SET R1=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1))
IF R1'?1N.N
QUIT
Begin DoDot:3
+11 SET R2=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1,0),U)
+12 WRITE !,?20,$PIECE($GET(^ACHSDENS(ACHDOTR,30,R2,0)),U)
End DoDot:3
End DoDot:2
+13 SET ACHDREA(ACHDCNT)=ACHDREA_U_ACHDOTR_U_ACHDROPT
End DoDot:1
+14 ;
OTHR1 ;
+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>ACHDCNT)!((%="OTHER")&('$DATA(ACHDREA(Y))))
WRITE !,"Please enter a number from 1 to ",ACHDCNT,"."
GOTO OTHR1
+6 SET ACHDRED=+Y
SET ACHDR=$SELECT(%="OTHER":"Other",1:"Primary")
+7 DO @%
+8 GOTO TOF
+9 ;
END ;
+1 KILL ACHDREA,TMP
+2 QUIT
+3 ;
PRIM ;
+1 DO REA
+2 IF X="@"
WRITE !!?5,"Must have a Primary Denial Reason."
HANG 1
QUIT
+3 ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
+4 SET (X,ACHDOTR,ACHDENR)=+Y
+5 SET ACHDORNM=$PIECE(ACHDREA(ACHDRED),U)
+6 SET ACHDOREO=$PIECE($GET(^ACHSDENS(ACHDOTR,0)),U)
+7 IF ACHDOTR'=$PIECE(ACHDREA(ACHDRED),U,2)
IF $$REASCK^ACHSDN2()
GOTO PRIM
DO PRMSET
+8 IF $DATA(DUOUT)
QUIT
+9 DO REAOPT^ACHSDN2
+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
+2 SET ACHDORNM=$PIECE(ACHDREA(ACHDRED),U)
+3 ;THEN DELETE ENTRY...
IF X="@"
DO OTHSET
QUIT
+4 ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
+5 SET (X,ACHDOTR)=+Y
+6 SET ACHDOREO=$PIECE($GET(^ACHSDENS(ACHDOTR,0)),U)
+7 IF ACHDOTR'=$PIECE(ACHDREA(ACHDRED),U,2)
IF $$REASCK^ACHSDN2()
GOTO OTHER
DO OTHSET
+8 DO OPTSET
+9 DO OTHREA1^ACHSDN2
+10 QUIT
REA ;
+1 SET X=0
SET CT=0
+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 ACHDENS(CT)=X_U_$PIECE(^ACHSDENS(X,0),U)
+7 IF X=$PIECE(ACHDREA(ACHDRED),U,2)
SET ACHDREDT=CT
End DoDot:1
+8 IF CT=0
WRITE !,"No active Denial Reasons"
SET Y=-1
QUIT
+9 WRITE !
+10 SET DIR(0)="NO^1:"_CT
+11 SET DIR("A")="Enter "_ACHDR_" Denial Reason: "_$PIECE(^ACHSDENS($PIECE(ACHDREA(ACHDRED),U,2),0),U)
+12 SET DIR("B")=ACHDREDT
+13 DO ^DIR
+14 ;ACHS*3.1*21 CHANGED NXT LINE
+15 ;I +Y>0 S Y=ACHDENS(Y)
+16 SET TMP=""
+17 IF +Y>0
SET TMP=ACHDENS(Y)
+18 IF ACHDR["Primary"
IF +Y>0
IF Y'=ACHDREDT
DO PRMDEL
+19 IF ACHDR["Other"
IF +Y>0
IF Y'=ACHDREDT
IF ACHDCNT>1
SET X="@"
SET ACHDORNM=$PIECE(ACHDREA(ACHDRED),U)
Begin DoDot:1
+20 DO OTHSET
+21 IF $PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,0),U,4)<1
SET $PIECE(^(0),U,3,4)="1^1"
End DoDot:1
+22 IF TMP
SET Y=TMP
+23 KILL DIR
+24 QUIT
PRMSET ;PRIMARY DENIAL REASON SET
+1 SET ACHDENR=+Y
+2 ;ACHS*3.1*10 4.22.04 IHS/ITSC/FCJ TEST FOR REF TO SET DENIAL REASON
+3 ;ACHS*3.1*10 4.22.04
IF $GET(ACHSREF)
SET ACHSREF(1114)=ACHDENR
+4 ;ACHS*3.1*18 NEW LINE
SET ACHSDREA=$PIECE($GET(^ACHSDENS(ACHDENR,0)),U)
+5 IF '$$DIE^ACHSDN("250////"_ACHDENR)
QUIT
+6 IF $DATA(Y)
SET DUOUT=""
QUIT
+7 QUIT
PRMDEL ;PRIM DEL OTHER TYPE ;ACHS*3.1*21 NEW SECTION
+1 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,256))
QUIT
+2 SET DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",256,"
+3 SET DR=".01_///@"
+4 SET L=0
FOR
SET L=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,256,L))
IF L'?1N.N
QUIT
Begin DoDot:1
+5 SET DA(2)=DUZ(2)
+6 SET DA(1)=ACHSA
+7 SET DA=L
+8 DO ^DIE
End DoDot:1
+9 KILL DIE,DA,DR
+10 QUIT
OTHSET ;SET OTHER DENIAL REASON
+1 SET DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
+2 SET DA(2)=DUZ(2)
+3 SET DA(1)=ACHSA
+4 SET DA=ACHDORNM
+5 SET DR=".01_///"_X
+6 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","+")
SET DUOUT=""
QUIT
+7 DO ^DIE
+8 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","-")
SET DUOUT=""
QUIT
+9 KILL DIE,DA,DR
+10 QUIT
OPTSET ;SET OPTION
+1 DO OTHREAO^ACHSDN2
+2 QUIT
+3 ;
ADD ;ADD OTHER DENIAL REASON
+1 WRITE !!
+2 DO OTHREAS^ACHSDN2
+3 QUIT
+4 ;
