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

ACHSDN1.m

Go to the documentation of this file. 
  1. ACHSDN1 ; IHS/ITSC/PMF - DENIAL DATA ENTRY (2/2) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18**;JUN 11,2001
  1.  ;
  1.  ;3.1*6 4.21.03 IHS/SET/FCJ CHANGED TO ALLOW ICD9 
  1.  ;           INPUT FOR MEDICAL SERVICE
  1.  ;3.1*10 4.21.04 IHS/SET/FCJ ADDED VARS FROM REF AS DEFAULT 
  1.  ;3.1*11 8.26.04 IHS/SET/FCJ TEST MED PRI OF 1NUM 1APLHA
  1.  ;3.1*13 12.1.06 IHS/OIT/FCJ ADDED ABILITY TO "^" OUT
  1.  ;
  1. PRMPRV ;EP.
  1.  S Y="YES"
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ ADDED NXT LINE
  1.  S Y1="" I $G(ACHSREF(.07)) S Y1=$P(^AUTTVNDR(ACHSREF(.07),0),U) G P1
  1.  S X=$$DN^ACHS(100,1)  ;'CHS DENIAL DATA'- 'IS PRIMARY PROVIDER ON FILE?'
  1.  I $L(X) S Y=$S(X="N":"NO",1:"YES")
  1.  S %=$$DIR^ACHS("Y","Is the PRIMARY PROVIDER in the VENDOR file?",Y,"","^D Q1^ACHSDN2",2)
  1.  Q:$D(DTOUT)!$D(DUOUT)
  1.  G P2:'%
  1.  ;
  1. P1 ;
  1.  ;IF PRIMARY PROVIDER ON-FILE ASK FLDS 102 'PRIMARY PROVIDER (ON-FILE)'
  1.  ;                                     108 'EST. CHARGE (PRIM. PROV.)'
  1.  ;                                    109 'ACTUAL CHARGES (PRIM. PROV.)'
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ CMT OUT NXT LINE ADDED NXT 2 LINES
  1.  ;I '$$DIE^ACHSDN("100///Y;102;108;109",2) Q
  1.  S DR=$S($G(ACHSREF):"100///Y;102//"_Y1_";108;109",1:"100///Y;102;108;109")
  1.  I '$$DIE^ACHSDN(DR,2) Q
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ NXT 2 LNS FIXED NOT BEING ABLE TO EXIT
  1.  ;G PRMPRV:$D(Y)
  1.  I $D(Y) S ACHSERR=1 Q
  1.  ;
  1.  ;IF WE HAVE A 'PRIMARY PROVIDER POINTER DELETE THE 103 FIELD
  1.  ;'PRIMARY PROVIDER (NOT ON-FILE)' DO A CHECK
  1.  I $L($$DN^ACHS(100,2)) G:$$DIE^ACHSDN("103///@",2) PROVCK Q
  1.  W !!,"A primary provider must be entered - try again.",!!
  1.  G PRMPRV
  1.  ;
  1. P2 ;
  1.  I '$$DIE^ACHSDN("100///N;103:109",2) Q
  1.  G PRMPRV:$D(Y)
  1.  I $L($$DN^ACHS(100,3)),'$$DIE^ACHSDN("102///@",2) Q
  1.  ;
  1.  ;
  1. PROVCK ;
  1.  I $L($$DN^ACHS(100,2))!$L($$DN^ACHS(100,3)) G OTHER
  1.  W !!,*7,"A primary provider must be entered - try again."
  1.  G PRMPRV
  1.  ;
  1. OTHER ;
  1.  Q:$D(ACHDSP)
  1.  S %=$$DIR^ACHS("Y","Are there any other providers (vendors)?","NO","","^D PQ^ACHSDN1",2)
  1.  G PRMPRV:$D(DTOUT)!$D(DUOUT),PROV:%,ACCT
  1.  ;
  1. PROV ;
  1.  S %=$$DIR^ACHS("Y","Is this provider in the vendor file?","YES","","^D Q1^ACHSDN2",2)
  1.  G OTHER:$D(DUOUT)!$D(DTOUT)
  1.  G O1:%,O2
  1.  ;
  1. O1 ;
  1.  I '$$DIE^ACHSDN(200,2) Q    ;EDIT 'OTHER PROVIDER (ON-FILE)'
  1.  G OTHER
  1.  ;
  1. O2 ;
  1.  I '$$DIE^ACHSDN(210,2) Q    ;EDIT 'OTHER PROVIDER (NOT ON FILE)'
  1.  G OTHER
  1.  ;
  1. ACCT ;
  1.  I '$$DIE^ACHSDN(950,2) Q    ;EDIT 'PROVIDER ACCOUNT NUMBER'
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ ADDED ABILITY TO "^" OUT
  1.  G PRMPRV:$D(Y)
  1. TYPE ;
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ CMT OUT NXT LINE ADDED NXT 3 LINES
  1.  ;I '$$DIE^ACHSDN(110,2) Q    ;EDIT 'TYPE OF SERVICE' 
  1.  S Y=$S($G(ACHSREF(.14))="O":"OUTPATIENT",$G(ACHSREF(.14))="I":"INPATIENT",1:"")
  1.  S DR=$S($G(ACHSREF):"110//"_Y,1:110)
  1.  I '$$DIE^ACHSDN(DR,2) Q    ;EDIT 'TYPE OF SERVICE' 
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ ADDED ABILITY TO "^" OUT CHG NXT LNE
  1.  ;G PRMPRV:$D(Y) ;ACHS*3.1*13
  1.  G ACCT:$D(Y) ;ACHS*3.1*13
  1.  I '$L($$DN^ACHS(100,10)) W !!,*7,"A TYPE-OF-SERVICE entry must be entered - try again.",!! G TYPE
  1.  D REASON^ACHSDN2             ;ENTER 'DENIAL REASONS'
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ ADDED ABILITY TO "^" OUT
  1.  I ACHSERR S ACHSERR="" G TYPE
  1.  Q:$D(DUOUT)
  1. MEDPRI ;
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ CMT OUT NXT LINE ADDED NXT 3 LINES
  1.  ;I '$$DIE^ACHSDN(420,2) Q     ;ENTER 'MEDICAL PRIORITY CATEGORY'
  1.  I $G(ACHSREF(.32))?1A.A S Y=ACHSREF(.32) D
  1.  .S ACHSREF(.32)=$S(Y="I":1,Y="II":2,Y="III":3,Y="IV":4,Y="V":5,1:"")
  1.  ;3.1*11 8.26.04 IHS/SET/FCJ TEST MED PRI OF 1NUM 1APLHA
  1.  ;I $G(ACHSREF(.32))>5 S ACHSREF(.32)=""
  1.  I +$G(ACHSREF(.32))>5 S ACHSREF(.32)=""
  1.  ;S Y=$S($G(ACHSREF(.32)):$P(^ACHSMPRI(ACHSREF(.32),0),U),1:"")
  1.  S Y=$S($G(ACHSREF(.32)):$P(^ACHSMPRI(+$G(ACHSREF(.32)),0),U),1:"")
  1.  S DR=$S($G(ACHSREF):"420//"_Y,1:420)
  1.  I '$$DIE^ACHSDN(DR,2) Q     ;ENTER 'MEDICAL PRIORITY CATEGORY'
  1.  I $D(Y) G TYPE
  1.  D PRIORCK^ACHSDN2            ;CHECK IF ENTERED
  1.  Q:$D(DUOUT)
  1.  G MEDPRI:'Y
  1.  ;
  1.  ;
  1. DIAG ;
  1.  G ICD9:$$DN^ACHS(100,10)="I"   ;IF 'TYPE OF SERVICE' INPATIENT
  1.  ;ACHS*3.1*6 4.21.03 IHS/SET/FCJ CHANGE OUTPATIENT TO DENTAL
  1.  ;G CPT:$$DN^ACHS(100,10)="O"    ;IF 'TYPE OF SERVICE'  OUTPATIENT ;ACHS*3.1*6
  1.  G CPT:$$DN^ACHS(100,10)="D"   ;IF 'TYPE OF SERVICE' DENTAL ;ACHS*3.1*6
  1. ICD9 ;
  1.  I '$$DIE^ACHSDN(500,2) Q        ;EDIT 'DIAGNOSIS (ICD9)
  1.  G MEDPRI:$D(Y)
  1.  ;G DXCK   SEE COMMENT UNDER TAG DXCK      ;CHECK THAT DIAG IS ENTERED
  1.  ;
  1. CPT ;
  1.  I '$$DIE^ACHSDN(700,2) Q         ;EDIT 'PROCEDURE (CPT)
  1.  G MEDPRI:$D(Y)
  1.  ;G DXCK   SEE COMMENT UNDER TAG DXCK     ;CHECK THAT DIAG IS ENTERED
  1. DXCK ;
  1.  ;I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,500)) G DIAG DIAGNOSIS ICD9 NOT
  1.  ;NOT REQUIRED PER CHS WORKGROUP 2/22/2001
  1.  ;I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,700)) W !!,*7,"At least one PROCEDURE is required.",!! G CPT   NOT REQUIRED PER CHS WORKGROUP 2/22/2001
  1.  ;
  1.  ;EDIT 'OTHER RESOURCES' THESE ARE PRIVATE AND GOV. INSURANCE
  1. RESC ;
  1.  W !!
  1.  K DIC("A")
  1.  I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)) S ^ACHSDEN(DUZ(2),"D",ACHSA,800,0)=$$ZEROTH^ACHS(9002071,1,800)
  1.  ;
  1.  S DA(2)=DUZ(2)
  1.  S DA(1)=ACHSA
  1.  S DIC="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",800,"
  1.  ;
  1.  S DIC(0)="QALEM"
  1.  D ^DIC
  1.  G MEDPRI:X[U
  1.  G IHSRES:Y<1
  1.  ;
  1.  ;EDIT FIELDS 2-10 SUBFILE 'OTHER RESOURCES'
  1.  S DA=+Y
  1.  S DA(2)=DUZ(2)
  1.  S DA(1)=ACHSA
  1.  S DIE=DIC
  1.  S DR="2;3;6;8;4;5;9;10"
  1.  S DR="2:10"
  1.  D ^DIE
  1.  ;10/24/01  pmf  replace next line
  1.  ;Y is not an output of ^DIE, so why go somewhere based on it?
  1.  ;besides, we want to ask for another alt resource
  1.  ;G:$D(Y) DIAG
  1.  G RESC
  1.  ;
  1.  ;EDIT 'OTHER IHS RESOURCES'  OTHER FACILITIES THAT MAY HONOR
  1.  ;A REQUEST FOR SERVICE
  1. IHSRES ;
  1.  ;
  1.  W !!
  1.  I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,825,0)) S ^ACHSDEN(DUZ(2),"D",ACHSA,825,0)=$$ZEROTH^ACHS(9002071,1,825)
  1.  ;
  1.  S DA(2)=DUZ(2)
  1.  S DA(1)=ACHSA
  1.  S DIC="^ACHSDEN("_DUZ(2)_",""D"","_ACHSA_",825,"
  1.  S DIC(0)="QALEM"
  1.  D ^DIC
  1.  G RESC:X[U
  1.  G DOCCK:Y<1
  1.  ;
  1.  ;
  1. DOCCK ;
  1.  W !!
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Enter Document Control Information Now"
  1.  S DIR("B")="NO"
  1.  S DIR("?",1)="Answer 'Y' if patient or their representative is picking up the document in person."
  1.  S DIR("?")="Answer 'N' if document is being mailed."
  1.  D ^DIR
  1.  K DIR
  1.  G RESC:X[U
  1.  I 'Y G COMMENT
  1.  I '$$DIE^ACHSDN("850////Y") Q     ;FORCE ENTRY INTO 'DOCUMENT CONTROL'
  1.  G RESC:$D(Y)
  1.  I '$$DIE^ACHSDN("851:853",2) Q    ;EDIT 'RECEIPT TYPE'
  1.  ;                                      'DATE DENIAL RECEIVED'
  1.  ;                                      'PERSON RECEIVING DENIAL'
  1.  G RESC:$D(Y)
  1. COMMENT ;
  1.  I '$$DIE^ACHSDN(900,2) Q          ;EDIT 'CHS OFFICE COMMENTS'
  1. END ;
  1.  K DTOUT,DUOUT,ACHDENR
  1.  Q
  1.  ;
  1. PQ ;EP - From DIR
  1.  W !!,"If there are other vendors which must be provided with a copy of",!,"this denial letter, answer 'Y'.  If not, answer 'N'."
  1.  Q
  1.  ;