ACHSDN2 ; IHS/ITSC/PMF - DENIAL SET UP & DISPLAY ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,10,12,18,19,21,24**;JUN 11,2001;Build 43
;ACHS*3.1*3 improve denial/patient lookup
; also, handle 'alt resource availabe' as special
;ACHS*3.1*4 close device before passing DUMP to taskman
;ACHS*3.1*10 4.22.04 IHS/ITSC/FCJ TEST FOR REF TO SET DENIAL REASON
;ACHS*3.1*12 12.1.06 IHS/OIT/FCJ ADDED ABILILTY "^" OUT
;ACHS*3.1*18 8.29.2010 IHS.OIT.FCJ MULTIPLE CHANGES FOR REWRITE OF DENIAL LETTER
;
Q1 ;
W !!,"If the PROVIDER (vendor) is in the CHS VENDOR FILE,",!,"answer 'Y'. If not, answer 'N'.",!!
Q
;
PRIORCK ;EP - Enter Priority Category.
I $L($$DN^ACHS(400,2)) S Y=1 Q
S Y=0
W !!,*7,"A PRIORITY CATEGORY is required - try again."
Q
;
REASON ;EP - Enter Denial Reasons.
N ACHDORNM,ACHDOTR S ACHDOPTR="N"
D REAS1 Q:$D(DUOUT) D OTHREAS Q ;ACHS*3.1*18
REAS1 ;
;Primary Denial Reason
S ACHDROPT=""
I ACHDOPTR="N",$$DN^ACHS(250,1) W !!,"Primary Denial Reason: ",$P($G(^ACHSDENS($$DN^ACHS(250,1),0)),U) G OTHREAS
S Y=$$DICREA("Primary ")
;ACHS*3.1*12 12.1.06 IHS/OIT/FCJ ADDED ABILILTY "^" OUT
I ACHDOPTR="E" G REAS1:$$REASCK()
I $D(DUOUT) S ACHSERR=1 Q
I Y<0 D REASERR G REASON
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
;
REAOPT ;EP-ACHSDN4 ;ACHS*3.1*18
S Y=+$$DICOPT(ACHDENR,"Primary ")
I ACHDOPTR="E" Q:+Y<0 G REAOPT:$$OPTCK("P")
I +Y<0,(ACHSDREA["Residency")!(ACHSDREA["Notification")!(ACHSDREA["Alternate")!(ACHSDREA["Medical")!(ACHSDREA["Indian") W !,"Must select an option for this Denial Reason." G REAOPT ;ACHS*3.1*18
S ACHDROPT=Y
I Y>0,'$$DIE^ACHSDN("252///"_Y) Q
;
;1/10/02 pmf
;okay, we got a primary reason. Now, if that reason is
; 'Alternate Resource Available', ask them WHICH resource
;I X["Alternate Resource Available" D ^ACHSDN2A I $D(DTOUT)!$D(DUOUT)!$G(ACHSQUIT) Q ; ACHS*3.1*3
I ACHSDREA["Alternate Resource Available" D TYPPRI^ACHSDN2A I $D(DTOUT)!$D(DUOUT) Q ; ACHS*3.1*18
I '$$DIE^ACHSDN(255,2) Q ;DENIAL RESAON COMMENTS
Q ;ACHS*3.1*18
;
OTHREAS ;EP-ACHSDN4
I $D(^ACHSDEN(DUZ(2),"D",ACHSA,300)) D REASLST
S Y=$$DICREA("Other ")
I X[U S DUOUT="" Q
Q:Y<0
;
S ACHDOTR=+Y ; ACHS*3.1*3
S ACHDOREO=$P($G(^ACHSDENS(ACHDOTR,0)),U)
G OTHREAS:$$REASCK()
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)) S ^ACHSDEN(DUZ(2),"D",ACHSA,300,0)=$$ZEROTH^ACHS(9002071,1,300)
S ACHDORNM=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),U,3)+1
S ^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0)=ACHDOTR
S ^ACHSDEN(DUZ(2),"D",ACHSA,300,"B",ACHDOTR,ACHDORNM)=""
S $P(^ACHSDEN(DUZ(2),"D",ACHSA,300,0),U,3,4)=ACHDORNM_U_ACHDORNM
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0)) W !!,"YOUR ENTRY WAS NOT ACCEPTED",!,"PLEASE TRY AGAIN.",!! G OTHREAS
;
;if this reason has no options, ask for next reason
;I '$D(^ACHSDENS(ACHDOTR,20,0)) G OTHREA1
I $D(^ACHSDENS(ACHDOTR,20,0)) D OTHREAO
OTHREA1 ; --- Other Denial Reason : Comment
W !
S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
S DA(2)=DUZ(2)
S DA(1)=ACHSA
S DA=ACHDORNM
S DR=3
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","+") Q
D ^DIE
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","-") Q
I ACHDOPTR="N",'$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,1,0)) K ^ACHSDEN(DUZ(2),"D",ACHSA,300)
Q:ACHDOPTR="E"
G OTHREAS
;
OTHREAO ;EP-ACHSDN4 ;ACHS*3.1*18
;ask for option
S Y=$$DICOPT(ACHDOTR,"Other ")
G OTHREAO:$$OPTCK("O") ;ACHS*3.1*19 TEST FOR USING SAME OPT
;I $D(DUOUT) Q:ACHDOPTR="E" D DEL G OTHREAS ;ACHS*3.1*21 TEST FOR OPT ALREADY Selected
I $D(DUOUT),ACHDOPTR'="E" D DEL G OTHREAS
I $D(DUOUT),ACHDOPTR="E" D Q
.;TEST FOR REASONS REQ AN OPTION, IF NONE SELECTED DELETE
.I (ACHDOREO["Residency")!(ACHDOREO["Notification")!(ACHDOREO["Alternate")!(ACHDOREO["Medical")!(ACHDOREO["Indian") D
..S ACHDROPT=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0),U,2)
..I ACHDROPT="" D DEL Q
..I ACHDOREO["Alternate",$P(^ACHSDENS(ACHDOTR,20,ACHDROPT,0),U)["Eligible",'$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,4,"B")) D DEL
I +Y<0,(ACHDOREO["Residency")!(ACHDOREO["Notification")!(ACHDOREO["Alternate")!(ACHDOREO["Medical")!(ACHDOREO["Indian") W !,"Must select an option for this Denial Reason." G OTHREAO ;ACHS*3.1*18
I +Y<0 G OTHREA1
S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
S DA(2)=DUZ(2)
S DA(1)=ACHSA
S DA=ACHDORNM
S DR="2///"_+Y
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300,ACHDORNM)","+") Q
D ^DIE
I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300,ACHDORNM)","-") Q
S ACHDROPT=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0),U,2)
;
;1/14/02 pmf
;if the reason was alternate resource, ask which one
;I ACHDOREO["Alternate Resource Available" D ^ACHSDN2A I $D(DTOUT)!$D(DUOUT)!$G(ACHSQUIT) Q ; ACHS*3.1*3
I ACHDOREO["Alternate Resource Available" D TYPOTH^ACHSDN2A I $D(DTOUT)!$D(DUOUT)!$G(ACHSQUIT) Q ; ACHS*3.1*18
Q
;
REASERR ;
W !!,*7,*7,*7,"A Primary Denial Reason Must Be Entered",!,"Please Try Again.",!
Q
;
DICREA(R) ; --- Select Denial Reason.
;DISPLAY DEN REASONS ;ACHS*3.1*19 RE-WRITTEN FOR PATCH 19
N X
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 CT=0 W !,"No active Denial Reasons" S Y=-1 Q
W !
K DIR ;ACHS*3.1*24
S DIR(0)="NO^1:"_CT
S DIR("A")="Enter "_$G(R)_"Denial Reason "
D ^DIR
I +Y>0 S Y=ACHDENS(Y)
E S Y=-1
Q +Y
;
DICOPT(X,R) ; --- Select Denial reason Option.
I '$D(^ACHSDENS(X,20,0)) Q -1
;DISPLAY REA OPTIONS ;ACHS*3.1*19 REWRITTEN
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 ACHDENO(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=ACHDENO(Y)
E S Y=-1
K ACHSDENO
Q +Y
;
REASLST ; --- Display the other Denials entered.
;ACHS*3.1*19 REWROTE SECTION TO DISPLAY RES AND OPT
N X,Y,Y1
W !!?5,"SELECTED Primary Denial Reason: "
I $D(^ACHSDEN(DUZ(2),"D",ACHSA,250)) D
.S Y=$P(^ACHSDEN(DUZ(2),"D",ACHSA,250),U),Y1=$P(^ACHSDEN(DUZ(2),"D",ACHSA,250),U,2)
.Q:'Y
.Q:'$D(^ACHSDENS(Y))
.W !?8,$P($G(^ACHSDENS(Y,0)),U)
.I Y1 D
..W !,?10,$P($G(^ACHSDENS(Y,20,Y1,0)),U)
..I (($P($G(^ACHSDENS(Y,20,Y1,0)),U)["Eligible")!($P($G(^ACHSDENS(Y,20,Y1,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(Y,30,R2,0)),U)
W !?5,"SELECTED Other Denial Reasons: "
S X=0
F S X=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,X)) Q:X=""!(X'?1.N) D
.S Y=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0),U),Y1=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0),U,2)
.Q:'Y
.Q:'$D(^ACHSDENS(Y))
.W !?8,$P($G(^ACHSDENS($P(Y,U),0)),U)
.I Y1 D
..W !,?10,$P($G(^ACHSDENS(Y,20,Y1,0)),U)
..I (($P($G(^ACHSDENS(Y,20,Y1,0)),U)["Eligible")!($P($G(^ACHSDENS(Y,20,Y1,0)),U)["Failure")),$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4)) D
...S R1=0 F S R1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4,R1)) Q:R1'?1N.N D
....S R2=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4,R1,0),U)
....W !,?20,$P($G(^ACHSDENS(Y,30,R2,0)),U)
Q
;
REASCK() ; --- Check if the Denial reason has already been entered.
;ACHS*3.1*19 MULT CHANGES FOR BECAUSE WILL BE TESTING FOR OPTIONS SELETED
N X,X1,Y
S (X,X1,Y)=0
;X1=TOTAL OPTIONS AVAILABLE;X=TOTAL REASON OR OPTIONS USED
F S X=$O(^ACHSDENS(ACHDOTR,20,X)) Q:X'?1N.N D
.I $P(^ACHSDENS(ACHDOTR,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,ACHDOTR=$$DN^ACHS(250,1),ACHDOPTR="N" W !!,*7,*7,"DENIAL REASON/OPTIONS ALREADY SELECTED.",!! Q 1
S X=0 I ACHDOTR=$$DN^ACHS(250,1) S X=X+1
I $D(^ACHSDEN(DUZ(2),"D",300)) S L=0 F S L=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,L)) Q:L'?1N.N D
.I $P(^ACHSDEN(DUZ(2),"D",ACHSA,300,L,0),U)=ACHDOTR S X=X+1
I X<X1 Q Y
W !!?5,"ALL DENIAL REASON/OPTIONS ALREADY SELECTED. Need to select another.",!!
Q 1
OPTCK(T) ; CHECK FOR OPTIONS ALREADY SELECTED ;ACHS*3.1*19 NEW SECTION
S (X,X1)=0
I T="O",$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U)=ACHDOTR,$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U,2)=+Y W !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.",!! S X1=1 H 1 Q X1
F S X=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,X)) Q:+X=0 D Q:X1
.I ACHDOPTR="E",X=ACHDORNM Q ;ACHS*3.1*19
.Q:$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0)),U)'=ACHDOTR
.I $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0)),U,2)=+Y W !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.....",!! S X1=1 H 1
Q X1
;
DUMP ;EP - From Option.
;S DIC="^ACHSDEN("_DUZ(2)_",""D""," ; ACHS*3.1*3
;S DIC(0)="QAZEMI" ; ACHS*3.1*3
;S DIC("A")="Enter the DENIAL NUMBER or PATIENT NAME : " ; ACHS*3.1*3
;D ^DIC ; ACHS*3.1*3
;G K:+Y<1 ; ACHS*3.1*3
;S ACHD("DA")=+Y ; ACHS*3.1*3
;K DIC ; ACHS*3.1*3
;
S ACHDOCT="denial" ; ACHS*3.1*3
D ^ACHSDLK ; ACHS*3.1*3
I $D(ACHDLKER) D K Q ; ACHS*3.1*3
S ACHD("DA")=ACHSA ; ACHS*3.1*3
;
DEV ; --- Select print device
S %ZIS="OPQ"
D ^%ZIS
I POP D HOME^%ZIS G K
G:'$D(IO("Q")) START
K IO("Q")
I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
;
;ACHS*3.1*4 pmf close the device before passing off to taskman
S ZTIO=ION ; ACHS*3.1*4
D ^%ZISC,HOME^%ZIS ; ACHS*3.1*4
;
S ZTRTN="START^ACHSDN2",ZTDESC="DUMP OF DATA FROM DENIAL DOCUMENT "_$P($G(^ACHSDEN(DUZ(2),"D",ACHD("DA"),0)),U)_"."
F %="AC*","ACHD*" S ZTSAVE(%)=""
D ^%ZTLOAD
G DEV:'$D(ZTSK)
K ZTSK
G K
;
START ;EP - TaskMan.
S:$D(IO("S")) IOSL=66
U IO
S DIC="^ACHSDEN("_DUZ(2)_",""D"",",DA=ACHD("DA")
D EN^DIQ
I IO'=ACHDIO W @IOF
K ;
K ACHD("DA")
D ^%ZISC,ERPT^ACHS:$D(ZTSK)
Q
;
DOCNTL ;EP - From Option.
N ACHSA,DA,DIC,DIE
S DIC="^ACHSDEN("_DUZ(2)_",""D"","
S DA(1)=DUZ(2)
S DIC(0)="AQEM"
D ^DIC
Q:Y<1
S ACHSA=+Y
I $$DIE^ACHSDN("850////Y;851:853",2)
Q
;
APPEAL ;EP - From Option.
W !!
S DIC="^ACHSDEN("_DUZ(2)_",""D"","
S DA(1)=DUZ(2)
S DIC(0)="AQEM"
D ^DIC
Q:Y<1
S DIC=DIC_+Y_",800,"
D ^DIC
;IHS/ITSC/PMF 1/12/01 add message before quitting Q:Y<1
I Y<1 W !!,?5,"No alternate resource info found.",! D RTRN^ACHS Q
S DIE=DIC,DA=+Y,DR="3;4;8;9;10;",DR(1,9002071)="1;",DR(1,9002071.01)="800;",DR(1,9002071.08)="3;4;8;9;10;",DR(1,9002071.84)=".01"
D ^DIE
Q
DEL ; DELETE REASON IF NO ^ OUT OF OPTION
;
S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
S DA(2)=DUZ(2)
S DA(1)=ACHSA
S DA=ACHDORNM
S DR=".01///"_"@"
D ^DIE
Q
ACHSDN2 ; IHS/ITSC/PMF - DENIAL SET UP & DISPLAY ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,10,12,18,19,21,24**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*3 improve denial/patient lookup
+3 ; also, handle 'alt resource availabe' as special
+4 ;ACHS*3.1*4 close device before passing DUMP to taskman
+5 ;ACHS*3.1*10 4.22.04 IHS/ITSC/FCJ TEST FOR REF TO SET DENIAL REASON
+6 ;ACHS*3.1*12 12.1.06 IHS/OIT/FCJ ADDED ABILILTY "^" OUT
+7 ;ACHS*3.1*18 8.29.2010 IHS.OIT.FCJ MULTIPLE CHANGES FOR REWRITE OF DENIAL LETTER
+8 ;
Q1 ;
+1 WRITE !!,"If the PROVIDER (vendor) is in the CHS VENDOR FILE,",!,"answer 'Y'. If not, answer 'N'.",!!
+2 QUIT
+3 ;
PRIORCK ;EP - Enter Priority Category.
+1 IF $LENGTH($$DN^ACHS(400,2))
SET Y=1
QUIT
+2 SET Y=0
+3 WRITE !!,*7,"A PRIORITY CATEGORY is required - try again."
+4 QUIT
+5 ;
REASON ;EP - Enter Denial Reasons.
+1 NEW ACHDORNM,ACHDOTR
SET ACHDOPTR="N"
+2 ;ACHS*3.1*18
DO REAS1
IF $DATA(DUOUT)
QUIT
DO OTHREAS
QUIT
REAS1 ;
+1 ;Primary Denial Reason
+2 SET ACHDROPT=""
+3 IF ACHDOPTR="N"
IF $$DN^ACHS(250,1)
WRITE !!,"Primary Denial Reason: ",$PIECE($GET(^ACHSDENS($$DN^ACHS(250,1),0)),U)
GOTO OTHREAS
+4 SET Y=$$DICREA("Primary ")
+5 ;ACHS*3.1*12 12.1.06 IHS/OIT/FCJ ADDED ABILILTY "^" OUT
+6 IF ACHDOPTR="E"
IF $$REASCK()
GOTO REAS1
+7 IF $DATA(DUOUT)
SET ACHSERR=1
QUIT
+8 IF Y<0
DO REASERR
GOTO REASON
+9 SET ACHDENR=+Y
+10 ;ACHS*3.1*10 4.22.04 IHS/ITSC/FCJ TEST FOR REF TO SET DENIAL REASON
+11 ;ACHS*3.1*10 4.22.04
IF $GET(ACHSREF)
SET ACHSREF(1114)=ACHDENR
+12 ;ACHS*3.1*18 NEW LINE
SET ACHSDREA=$PIECE($GET(^ACHSDENS(ACHDENR,0)),U)
+13 IF '$$DIE^ACHSDN("250////"_ACHDENR)
QUIT
+14 IF $DATA(Y)
SET DUOUT=""
QUIT
+15 ;
REAOPT ;EP-ACHSDN4 ;ACHS*3.1*18
+1 SET Y=+$$DICOPT(ACHDENR,"Primary ")
+2 IF ACHDOPTR="E"
IF +Y<0
QUIT
IF $$OPTCK("P")
GOTO REAOPT
+3 ;ACHS*3.1*18
IF +Y<0
IF (ACHSDREA["Residency")!(ACHSDREA["Notification")!(ACHSDREA["Alternate")!(ACHSDREA["Medical")!(ACHSDREA["Indian")
WRITE !,"Must select an option for this Denial Reason."
GOTO REAOPT
+4 SET ACHDROPT=Y
+5 IF Y>0
IF '$$DIE^ACHSDN("252///"_Y)
QUIT
+6 ;
+7 ;1/10/02 pmf
+8 ;okay, we got a primary reason. Now, if that reason is
+9 ; 'Alternate Resource Available', ask them WHICH resource
+10 ;I X["Alternate Resource Available" D ^ACHSDN2A I $D(DTOUT)!$D(DUOUT)!$G(ACHSQUIT) Q ; ACHS*3.1*3
+11 ; ACHS*3.1*18
IF ACHSDREA["Alternate Resource Available"
DO TYPPRI^ACHSDN2A
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+12 ;DENIAL RESAON COMMENTS
IF '$$DIE^ACHSDN(255,2)
QUIT
+13 ;ACHS*3.1*18
QUIT
+14 ;
OTHREAS ;EP-ACHSDN4
+1 IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300))
DO REASLST
+2 SET Y=$$DICREA("Other ")
+3 IF X[U
SET DUOUT=""
QUIT
+4 IF Y<0
QUIT
+5 ;
+6 ; ACHS*3.1*3
SET ACHDOTR=+Y
+7 SET ACHDOREO=$PIECE($GET(^ACHSDENS(ACHDOTR,0)),U)
+8 IF $$REASCK()
GOTO OTHREAS
+9 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,0))
SET ^ACHSDEN(DUZ(2),"D",ACHSA,300,0)=$$ZEROTH^ACHS(9002071,1,300)
+10 SET ACHDORNM=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,300,0)),U,3)+1
+11 SET ^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0)=ACHDOTR
+12 SET ^ACHSDEN(DUZ(2),"D",ACHSA,300,"B",ACHDOTR,ACHDORNM)=""
+13 SET $PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,0),U,3,4)=ACHDORNM_U_ACHDORNM
+14 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0))
WRITE !!,"YOUR ENTRY WAS NOT ACCEPTED",!,"PLEASE TRY AGAIN.",!!
GOTO OTHREAS
+15 ;
+16 ;if this reason has no options, ask for next reason
+17 ;I '$D(^ACHSDENS(ACHDOTR,20,0)) G OTHREA1
+18 IF $DATA(^ACHSDENS(ACHDOTR,20,0))
DO OTHREAO
OTHREA1 ; --- Other Denial Reason : Comment
+1 WRITE !
+2 SET DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
+3 SET DA(2)=DUZ(2)
+4 SET DA(1)=ACHSA
+5 SET DA=ACHDORNM
+6 SET DR=3
+7 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","+")
QUIT
+8 DO ^DIE
+9 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","-")
QUIT
+10 IF ACHDOPTR="N"
IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,1,0))
KILL ^ACHSDEN(DUZ(2),"D",ACHSA,300)
+11 IF ACHDOPTR="E"
QUIT
+12 GOTO OTHREAS
+13 ;
OTHREAO ;EP-ACHSDN4 ;ACHS*3.1*18
+1 ;ask for option
+2 SET Y=$$DICOPT(ACHDOTR,"Other ")
+3 ;ACHS*3.1*19 TEST FOR USING SAME OPT
IF $$OPTCK("O")
GOTO OTHREAO
+4 ;I $D(DUOUT) Q:ACHDOPTR="E" D DEL G OTHREAS ;ACHS*3.1*21 TEST FOR OPT ALREADY Selected
+5 IF $DATA(DUOUT)
IF ACHDOPTR'="E"
DO DEL
GOTO OTHREAS
+6 IF $DATA(DUOUT)
IF ACHDOPTR="E"
Begin DoDot:1
+7 ;TEST FOR REASONS REQ AN OPTION, IF NONE SELECTED DELETE
+8 IF (ACHDOREO["Residency")!(ACHDOREO["Notification")!(ACHDOREO["Alternate")!(ACHDOREO["Medical")!(ACHDOREO["Indian")
Begin DoDot:2
+9 SET ACHDROPT=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0),U,2)
+10 IF ACHDROPT=""
DO DEL
QUIT
+11 IF ACHDOREO["Alternate"
IF $PIECE(^ACHSDENS(ACHDOTR,20,ACHDROPT,0),U)["Eligible"
IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,4,"B"))
DO DEL
End DoDot:2
End DoDot:1
QUIT
+12 ;ACHS*3.1*18
IF +Y<0
IF (ACHDOREO["Residency")!(ACHDOREO["Notification")!(ACHDOREO["Alternate")!(ACHDOREO["Medical")!(ACHDOREO["Indian")
WRITE !,"Must select an option for this Denial Reason."
GOTO OTHREAO
+13 IF +Y<0
GOTO OTHREA1
+14 SET DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
+15 SET DA(2)=DUZ(2)
+16 SET DA(1)=ACHSA
+17 SET DA=ACHDORNM
+18 SET DR="2///"_+Y
+19 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300,ACHDORNM)","+")
QUIT
+20 DO ^DIE
+21 IF '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300,ACHDORNM)","-")
QUIT
+22 SET ACHDROPT=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDORNM,0),U,2)
+23 ;
+24 ;1/14/02 pmf
+25 ;if the reason was alternate resource, ask which one
+26 ;I ACHDOREO["Alternate Resource Available" D ^ACHSDN2A I $D(DTOUT)!$D(DUOUT)!$G(ACHSQUIT) Q ; ACHS*3.1*3
+27 ; ACHS*3.1*18
IF ACHDOREO["Alternate Resource Available"
DO TYPOTH^ACHSDN2A
IF $DATA(DTOUT)!$DATA(DUOUT)!$GET(ACHSQUIT)
QUIT
+28 QUIT
+29 ;
REASERR ;
+1 WRITE !!,*7,*7,*7,"A Primary Denial Reason Must Be Entered",!,"Please Try Again.",!
+2 QUIT
+3 ;
DICREA(R) ; --- Select Denial Reason.
+1 ;DISPLAY DEN REASONS ;ACHS*3.1*19 RE-WRITTEN FOR PATCH 19
+2 NEW X
+3 SET X=0
SET CT=0
+4 WRITE !!?3,"Denial Reason List:"
+5 FOR
SET X=$ORDER(^ACHSDENS(X))
IF X'?1N.N
QUIT
Begin DoDot:1
+6 IF $DATA(^ACHSDENS(X,10))
IF $PIECE(^ACHSDENS(X,10),U)>""
IF $PIECE(^ACHSDENS(X,10),U)<DT
QUIT
+7 SET CT=CT+1
WRITE !?5,CT,". ",$PIECE(^ACHSDENS(X,0),U)
+8 SET ACHDENS(CT)=X_U_$PIECE(^ACHSDENS(X,0),U)
End DoDot:1
+9 IF CT=0
WRITE !,"No active Denial Reasons"
SET Y=-1
QUIT
+10 WRITE !
+11 ;ACHS*3.1*24
KILL DIR
+12 SET DIR(0)="NO^1:"_CT
+13 SET DIR("A")="Enter "_$GET(R)_"Denial Reason "
+14 DO ^DIR
+15 IF +Y>0
SET Y=ACHDENS(Y)
+16 IF '$TEST
SET Y=-1
+17 QUIT +Y
+18 ;
DICOPT(X,R) ; --- Select Denial reason Option.
+1 IF '$DATA(^ACHSDENS(X,20,0))
QUIT -1
+2 ;DISPLAY REA OPTIONS ;ACHS*3.1*19 REWRITTEN
+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 ACHDENO(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=ACHDENO(Y)
+15 IF '$TEST
SET Y=-1
+16 KILL ACHSDENO
+17 QUIT +Y
+18 ;
REASLST ; --- Display the other Denials entered.
+1 ;ACHS*3.1*19 REWROTE SECTION TO DISPLAY RES AND OPT
+2 NEW X,Y,Y1
+3 WRITE !!?5,"SELECTED Primary Denial Reason: "
+4 IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,250))
Begin DoDot:1
+5 SET Y=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,250),U)
SET Y1=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,250),U,2)
+6 IF 'Y
QUIT
+7 IF '$DATA(^ACHSDENS(Y))
QUIT
+8 WRITE !?8,$PIECE($GET(^ACHSDENS(Y,0)),U)
+9 IF Y1
Begin DoDot:2
+10 WRITE !,?10,$PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)
+11 IF (($PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)["Eligible")!($PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)["Failure"))
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,256))
Begin DoDot:3
+12 SET R1=0
FOR
SET R1=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1))
IF R1'?1N.N
QUIT
Begin DoDot:4
+13 SET R2=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,256,R1,0),U)
+14 WRITE !,?20,$PIECE($GET(^ACHSDENS(Y,30,R2,0)),U)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 WRITE !?5,"SELECTED Other Denial Reasons: "
+16 SET X=0
+17 FOR
SET X=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,X))
IF X=""!(X'?1.N)
QUIT
Begin DoDot:1
+18 SET Y=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0),U)
SET Y1=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0),U,2)
+19 IF 'Y
QUIT
+20 IF '$DATA(^ACHSDENS(Y))
QUIT
+21 WRITE !?8,$PIECE($GET(^ACHSDENS($PIECE(Y,U),0)),U)
+22 IF Y1
Begin DoDot:2
+23 WRITE !,?10,$PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)
+24 IF (($PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)["Eligible")!($PIECE($GET(^ACHSDENS(Y,20,Y1,0)),U)["Failure"))
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4))
Begin DoDot:3
+25 SET R1=0
FOR
SET R1=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4,R1))
IF R1'?1N.N
QUIT
Begin DoDot:4
+26 SET R2=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,4,R1,0),U)
+27 WRITE !,?20,$PIECE($GET(^ACHSDENS(Y,30,R2,0)),U)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;
REASCK() ; --- Check if the Denial reason has already been entered.
+1 ;ACHS*3.1*19 MULT CHANGES FOR BECAUSE WILL BE TESTING FOR OPTIONS SELETED
+2 NEW X,X1,Y
+3 SET (X,X1,Y)=0
+4 ;X1=TOTAL OPTIONS AVAILABLE;X=TOTAL REASON OR OPTIONS USED
+5 FOR
SET X=$ORDER(^ACHSDENS(ACHDOTR,20,X))
IF X'?1N.N
QUIT
Begin DoDot:1
+6 IF $PIECE(^ACHSDENS(ACHDOTR,20,X,0),U,2)'=""
IF $PIECE(^(0),U,2)<DT
QUIT
+7 SET X1=X1+1
End DoDot:1
+8 ;I X1=0 NO OPTION AVAILABLE JUST USING REASON
+9 IF X1<2
IF ACHDOTR=$$DN^ACHS(250,1)
IF ACHDOPTR="N"
WRITE !!,*7,*7,"DENIAL REASON/OPTIONS ALREADY SELECTED.",!!
QUIT 1
+10 SET X=0
IF ACHDOTR=$$DN^ACHS(250,1)
SET X=X+1
+11 IF $DATA(^ACHSDEN(DUZ(2),"D",300))
SET L=0
FOR
SET L=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,L))
IF L'?1N.N
QUIT
Begin DoDot:1
+12 IF $PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,L,0),U)=ACHDOTR
SET X=X+1
End DoDot:1
+13 IF X<X1
QUIT Y
+14 WRITE !!?5,"ALL DENIAL REASON/OPTIONS ALREADY SELECTED. Need to select another.",!!
+15 QUIT 1
OPTCK(T) ; CHECK FOR OPTIONS ALREADY SELECTED ;ACHS*3.1*19 NEW SECTION
+1 SET (X,X1)=0
+2 IF T="O"
IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U)=ACHDOTR
IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,250)),U,2)=+Y
WRITE !!,*7,*7,"DENIAL REASON OPTION ALREADY SELECTED.",!!
SET X1=1
HANG 1
QUIT X1
+3 FOR
SET X=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,X))
IF +X=0
QUIT
Begin DoDot:1
+4 ;ACHS*3.1*19
IF ACHDOPTR="E"
IF X=ACHDORNM
QUIT
+5 IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,300,X,0)),U)'=ACHDOTR
QUIT
+6 IF $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,300,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 ;
DUMP ;EP - From Option.
+1 ;S DIC="^ACHSDEN("_DUZ(2)_",""D""," ; ACHS*3.1*3
+2 ;S DIC(0)="QAZEMI" ; ACHS*3.1*3
+3 ;S DIC("A")="Enter the DENIAL NUMBER or PATIENT NAME : " ; ACHS*3.1*3
+4 ;D ^DIC ; ACHS*3.1*3
+5 ;G K:+Y<1 ; ACHS*3.1*3
+6 ;S ACHD("DA")=+Y ; ACHS*3.1*3
+7 ;K DIC ; ACHS*3.1*3
+8 ;
+9 ; ACHS*3.1*3
SET ACHDOCT="denial"
+10 ; ACHS*3.1*3
DO ^ACHSDLK
+11 ; ACHS*3.1*3
IF $DATA(ACHDLKER)
DO K
QUIT
+12 ; ACHS*3.1*3
SET ACHD("DA")=ACHSA
+13 ;
DEV ; --- Select print device
+1 SET %ZIS="OPQ"
+2 DO ^%ZIS
+3 IF POP
DO HOME^%ZIS
GOTO K
+4 IF '$DATA(IO("Q"))
GOTO START
+5 KILL IO("Q")
+6 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+7 ;
+8 ;ACHS*3.1*4 pmf close the device before passing off to taskman
+9 ; ACHS*3.1*4
SET ZTIO=ION
+10 ; ACHS*3.1*4
DO ^%ZISC
DO HOME^%ZIS
+11 ;
+12 SET ZTRTN="START^ACHSDN2"
SET ZTDESC="DUMP OF DATA FROM DENIAL DOCUMENT "_$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHD("DA"),0)),U)_"."
+13 FOR %="AC*","ACHD*"
SET ZTSAVE(%)=""
+14 DO ^%ZTLOAD
+15 IF '$DATA(ZTSK)
GOTO DEV
+16 KILL ZTSK
+17 GOTO K
+18 ;
START ;EP - TaskMan.
+1 IF $DATA(IO("S"))
SET IOSL=66
+2 USE IO
+3 SET DIC="^ACHSDEN("_DUZ(2)_",""D"","
SET DA=ACHD("DA")
+4 DO EN^DIQ
+5 IF IO'=ACHDIO
WRITE @IOF
K ;
+1 KILL ACHD("DA")
+2 DO ^%ZISC
IF $DATA(ZTSK)
DO ERPT^ACHS
+3 QUIT
+4 ;
DOCNTL ;EP - From Option.
+1 NEW ACHSA,DA,DIC,DIE
+2 SET DIC="^ACHSDEN("_DUZ(2)_",""D"","
+3 SET DA(1)=DUZ(2)
+4 SET DIC(0)="AQEM"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET ACHSA=+Y
+8 IF $$DIE^ACHSDN("850////Y;851:853",2)
+9 QUIT
+10 ;
APPEAL ;EP - From Option.
+1 WRITE !!
+2 SET DIC="^ACHSDEN("_DUZ(2)_",""D"","
+3 SET DA(1)=DUZ(2)
+4 SET DIC(0)="AQEM"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET DIC=DIC_+Y_",800,"
+8 DO ^DIC
+9 ;IHS/ITSC/PMF 1/12/01 add message before quitting Q:Y<1
+10 IF Y<1
WRITE !!,?5,"No alternate resource info found.",!
DO RTRN^ACHS
QUIT
+11 SET DIE=DIC
SET DA=+Y
SET DR="3;4;8;9;10;"
SET DR(1,9002071)="1;"
SET DR(1,9002071.01)="800;"
SET DR(1,9002071.08)="3;4;8;9;10;"
SET DR(1,9002071.84)=".01"
+12 DO ^DIE
+13 QUIT
DEL ; DELETE REASON IF NO ^ OUT OF OPTION
+1 ;
+2 SET DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",300,"
+3 SET DA(2)=DUZ(2)
+4 SET DA(1)=ACHSA
+5 SET DA=ACHDORNM
+6 SET DR=".01///"_"@"
+7 DO ^DIE
+8 QUIT
