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

ACHSDN4.m

Go to the documentation of this file. 
  1. 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
  1.  ;ACHS*3.1*19 Rewrote routine
  1.  ;
  1.  N ALT,DAT,SS
  1.  ;
  1. TOF ;
  1.  S ACHDOPTR="E"
  1.  W @IOF,$$REPEAT^XLFSTR("=",79),!?30,"DENIAL REASONS EDIT",!,$$REPEAT^XLFSTR("=",79),!!,"PRIMARY DENIAL REASON: ",!
  1.  S X=$$DN^ACHS(250,1),X1=$$DN^ACHS(250,2)
  1.  I X,$D(^ACHSDENS(X,0)) D  G OTHREAS
  1.  .W !?10,"1. ",$P($G(^ACHSDENS(X,0)),U),!
  1.  .W:X1 ?15,$P($G(^ACHSDENS(X,20,X1,0)),U)
  1.  .S ACHDREA(1)=U_X_U_X1
  1.  .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
  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(X,30,R2,0)),U)
  1.  W !!,*7,*7,"No Primary Denial Reason Has Been Entered, But is required" D PRIM
  1.  K ACHDREA G TOF
  1.  ;
  1. 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: ",!
  1.  S ACHDREA=0,ACHDCNT=1
  1.  F  S ACHDREA=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA)) Q:ACHDREA'?1.N  D
  1.  .I ACHDCNT=1 W !!,"OTHER DENIAL REASONS: ",!
  1.  .S ACHDCNT=ACHDCNT+1
  1.  .S ACHDOTR=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,0),U),ACHDROPT=$P(^(0),U,2)
  1.  .W !?10,ACHDCNT,". ",$P($G(^ACHSDENS(ACHDOTR,0)),U),!
  1.  .I ACHDROPT W ?15,$P($G(^ACHSDENS(ACHDOTR,20,ACHDROPT,0)),U)
  1.  .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
  1.  ..S R1=0 F  S R1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1)) Q:R1'?1N.N  D
  1.  ...S R2=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDREA,4,R1,0),U)
  1.  ...W !,?20,$P($G(^ACHSDENS(ACHDOTR,30,R2,0)),U)
  1.  .S ACHDREA(ACHDCNT)=ACHDREA_U_ACHDOTR_U_ACHDROPT
  1.  ;
  1. OTHR1 ;
  1.  ;
  1.  S %=$$DIR^ACHS("FO","Enter Number Of Reason To Edit, 'A' To ADD Reason","","","",2)
  1.  I (%="")!$D(DUOUT)!$D(DTOUT) D END Q
  1.  S Y=+%,%=$S(+%=1:"PRIM","Aa"[%:"ADD",1:"OTHER")
  1.  I (Y>ACHDCNT)!((%="OTHER")&('$D(ACHDREA(Y)))) W !,"Please enter a number from 1 to ",ACHDCNT,"." G OTHR1
  1.  S ACHDRED=+Y,ACHDR=$S(%="OTHER":"Other",1:"Primary")
  1.  D @%
  1.  G TOF
  1.  ;
  1. END ;
  1.  K ACHDREA,TMP
  1.  Q
  1.  ;
  1. PRIM ;
  1.  D REA
  1.  I X="@" W !!?5,"Must have a Primary Denial Reason." H 1 Q
  1.  ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
  1.  S (X,ACHDOTR,ACHDENR)=+Y
  1.  S ACHDORNM=$P(ACHDREA(ACHDRED),U)
  1.  S ACHDOREO=$P($G(^ACHSDENS(ACHDOTR,0)),U)
  1.  I ACHDOTR'=$P(ACHDREA(ACHDRED),U,2) G PRIM:$$REASCK^ACHSDN2() D PRMSET
  1.  Q:$D(DUOUT)
  1.  D REAOPT^ACHSDN2
  1.  I $D(Y),+Y<0 W !?5,"Denial Option did not change." H 1
  1.  Q
  1.  ;
  1. OTHER ;EDIT OTHER DENIAL REASON
  1.  D REA
  1.  S ACHDORNM=$P(ACHDREA(ACHDRED),U)
  1.  I X="@" D OTHSET Q  ;THEN DELETE ENTRY...
  1.  ;I EDITING REASON THEN CHECK TO SEE IF DUPLICATE
  1.  S (X,ACHDOTR)=+Y
  1.  S ACHDOREO=$P($G(^ACHSDENS(ACHDOTR,0)),U)
  1.  I ACHDOTR'=$P(ACHDREA(ACHDRED),U,2) G OTHER:$$REASCK^ACHSDN2() D OTHSET
  1.  D OPTSET
  1.  D OTHREA1^ACHSDN2
  1.  Q
  1. REA ;
  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 X=$P(ACHDREA(ACHDRED),U,2) S ACHDREDT=CT
  1.  I CT=0 W !,"No active Denial Reasons" S Y=-1 Q
  1.  W !
  1.  S DIR(0)="NO^1:"_CT
  1.  S DIR("A")="Enter "_ACHDR_" Denial Reason: "_$P(^ACHSDENS($P(ACHDREA(ACHDRED),U,2),0),U)
  1.  S DIR("B")=ACHDREDT
  1.  D ^DIR
  1.  ;ACHS*3.1*21 CHANGED NXT LINE
  1.  ;I +Y>0 S Y=ACHDENS(Y)
  1.  S TMP=""
  1.  I +Y>0 S TMP=ACHDENS(Y)
  1.  I ACHDR["Primary",+Y>0,Y'=ACHDREDT D PRMDEL
  1.  I ACHDR["Other",+Y>0,Y'=ACHDREDT,ACHDCNT>1 S X="@",ACHDORNM=$P(ACHDREA(ACHDRED),U) D
  1.  .D OTHSET
  1.  .I $P(^ACHSDEN(DUZ(2),"D",ACHSA,300,0),U,4)<1 S $P(^(0),U,3,4)="1^1"
  1.  S:TMP Y=TMP
  1.  K DIR
  1.  Q
  1. PRMSET ;PRIMARY DENIAL REASON SET
  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.  Q
  1. PRMDEL ;PRIM DEL OTHER TYPE ;ACHS*3.1*21 NEW SECTION
  1.  Q:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,256))
  1.  S DIE="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",256,"
  1.  S DR=".01_///@"
  1.  S L=0 F  S L=$O(^ACHSDEN(DUZ(2),"D",ACHSA,256,L)) Q:L'?1N.N  D
  1.  .S DA(2)=DUZ(2)
  1.  .S DA(1)=ACHSA
  1.  .S DA=L
  1.  .D ^DIE
  1.  K DIE,DA,DR
  1.  Q
  1. OTHSET ;SET OTHER DENIAL REASON
  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_///"_X
  1.  I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","+") S DUOUT="" Q
  1.  D ^DIE
  1.  I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA,300)","-") S DUOUT="" Q
  1.  K DIE,DA,DR
  1.  Q
  1. OPTSET ;SET OPTION
  1.  D OTHREAO^ACHSDN2
  1.  Q
  1.  ;
  1. ADD ;ADD OTHER DENIAL REASON
  1.  W !!
  1.  D OTHREAS^ACHSDN2
  1.  Q
  1.  ;