Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSDN2

ACHSDN2.m

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