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

ACHSDN.m

Go to the documentation of this file. 
  1. ACHSDN ; IHS/ITSC/PMF - DENIAL DATA ENTRY (1/2) ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**10,11,12,13,18,21**;JUN 11,2001;Build 43
  1.  ;3.1*10 4.21.03 IHS/ITSC/FCJ TEST FOR RCIS IF LINK IS ON WILL NOW SET
  1.  ;       DEFAULT VARS AND CLOSE REF ONCE DENIAL IS COMPLETE
  1.  ;3.1*11 8.24.03 IHS/ITSC/FCJ TEST FOR RCIS VERSION
  1.  ;3.1*12 1.4.04 IHS/ITSC/JVK TEST FOR PAWNEE BEN PKG
  1.  ;3.1*13 12.1.06 IHS/OIT/FCJ COULD NOT ^ OUT OF DATA ENTRY
  1.  ;3.1*18 4/1/2010;IHS/CNI/ABK;Change every occurrance of Deferred to Unmet Need
  1.  ;
  1. SITE ;
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ S ACHSERR VAR USED WHEN EXITING DATA ENTRY
  1.  ;S ACHDREG=""
  1.  S ACHDREG="",ACHSERR=""
  1.  D SETCK^ACHSDF1             ;SETUP SITE PARAMETERS
  1.  ;                           REMOVE INCOMPLETE DENIALS
  1.  I $D(ACHS("NOTSET")) D END Q
  1.  ;
  1. START ;EP --- Set the pseudo number of a Denial and begin entering data.
  1.  I '$D(^ACHSDEN(DUZ(2),0)) S ^ACHSDEN(DUZ(2),0)=DUZ(2),DIK="^ACHSDEN(",DA=DUZ(2),DIK(1)=".01" D EN^DIK K DIK,DA
  1.  ;
  1.  I '($D(^ACHSDEN(DUZ(2),"D",0))#10) S ^ACHSDEN(DUZ(2),"D",0)=$$ZEROTH^ACHS(9002071,1)
  1.  ;
  1.  K DIC
  1.  S DIC="^ACHSDEN("_DUZ(2)_",""D"",",DA(1)=DUZ(2)
  1.  S DIC(0)="L"
  1.  S X="#"_$P($H,",",1)_"#"_$P($H,",",2)
  1.  D ^DIC K DIC
  1.  I +Y<1 D END Q
  1.  S ACHSA=+Y
  1.  ;
  1.  ;FORCE ENTER 'DATE DENIAL ISSUED' AND 'ISSUED BY'
  1.  I '$$DIE("2////"_DT_";3////"_DUZ) D END Q
  1.  ;
  1. PAT ; ---  Select the patient for this Denial.
  1.  G P2:ACHDREG="N"
  1.  G P1:ACHDREG="Y"
  1.  ;
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ REMOVED EXTRA ?
  1.  ;S Y=$$DIR^ACHS("Y","Is the patient REGISTERED IN THIS COMPUTER? ","YES","","",2) ;ACHS*3.1*10 4.21.04
  1.  S Y=$$DIR^ACHS("Y","Is the patient REGISTERED IN THIS COMPUTER","YES","","",2)  ;ACHS*3.1*10 4.21.04
  1.  I $D(DTOUT)!$D(DUOUT) D END Q
  1.  G P1:Y
  1.  G P2
  1.  ;
  1. P1 ; ---  Patient is registered.
  1.  ;ACHS*3.1*10 4.21.03 IHS/ITSC/FCJ TEST FOR RCIS
  1.  ;ACHS*3.1*11 8.24.03 IHS/ITSC/FCJ ADD TEST FOR RCIS VERSION
  1.  I $$LINK^ACHSBMC,$$VCHK^ACHSBMC>2 S ACHSREF="" D GETREF^ACHSBMC(.ACHSREF) G:$D(DFN) P1A ;ACHS*3.1*10 4.21.03
  1.  G:$D(DUOUT) PAT
  1.  S DFN=$$DN^ACHS(0,7)                ;GET 'REGISTERED PATIENT' PTR
  1.  I DFN,'$D(^DPT(DFN,0)) S DFN=""     ;
  1.  S AUPNX=0
  1.  I DFN="" D PTLK^ACHS G:'$G(DFN) PAT  ;THIS GIVES US PROBLEMS SOMETIMES
  1.  ;
  1.  ;ITSC/SET/JVK ACHS**TESTING**
  1.  ;S Y=$$DIR^ACHS("Y","Is this the correct patient REGISTERED IN THIS COMPUTER? ","YES","","",2) ;ACHS***
  1.  ;I 'Y D KILL Q
  1.  ;
  1.  I $D(DUOUT)!'$D(DFN)!$D(DTOUT) D KILL Q
  1.  ;
  1. P1A ;
  1.  ;ITSC/SET/JVK ACHS*3.1*12 ADD FOR IHS/OKCAO/POC PAWNEE BEN PKG
  1.  ;I '$D(^AUPNPAT(DFN,41,DUZ(2))) D  I ('%)!$D(DUOUT)!$D(DTOUT) D END Q
  1.  I (+$P($G(^AUTTLOC(DUZ(2),0)),U,10)'=505613)&('$D(^AUPNPAT(DFN,41,DUZ(2)))) D  I ('%)!$D(DUOUT)!$D(DTOUT) D END Q
  1.  . W !!,*7,*7,$$R("*",13)," THIS PATIENT HAS NO CHART AT THIS FACILITY.",$$R("*",12)
  1.  . W !,$$R("*",13)," THEY ARE REGISTERED AT :"
  1.  . S J=0
  1.  . F  S J=$O(^AUPNPAT(DFN,41,J)) Q:+J=0  W !?10,$P($G(^DIC(4,J,0)),U),?35,$P($G(^AUPNPAT(DFN,41,J,0)),U,2)
  1.  . W !,$$R("*",13),!,$$R("*",13)," YOU MUST ENTER THEIR CHART NUMBER FOR THIS FACILITY ",$$R("*",9),!!,"CONTINUE? ",!
  1.  .S %=$$DIR^ACHS("Y","Do you want to enter their Chart Number for this facility","NO","","",2)
  1.  . I %,'$$DIE(15) S %=0    ;'CHART # (OTHER FACILITY)'
  1.  ;
  1.  ;
  1.  I '$$DIE("6///Y;7////"_DFN) D END Q   ;FORCE ENTRY 'PATIENT REGISTERED'
  1.  ;                                    'REGISTERED PATIENT'  ?????
  1.  ;
  1.  ;IF THERE IS MISSING INFO IN 'PATIENT NAME' 'MAILING ADDRESS- STREET 'MAILING ADDRESS-CITY' 'MAILING ADDRESS- STATE' OR 'MAILING ADDRESS-ZIP' QUIT
  1.  I $D(^ACHSDEN(DUZ(2),"D",ACHSA,10)),'$$DIE("10///@;11///@;12///@;13///@;14///@") D END Q
  1.  ;
  1.  ;GET NAME AND ADDRESS INFO FROM PATIENT FILE (REGISTERED PATIENT)
  1.  S X=$G(^DPT(DFN,.11))
  1.  S Y=$P($G(^DPT(DFN,0)),U)
  1.  W !!,$P(Y,",",2)_" "_$P(Y,",",1),!,$P(X,U),!,$P(X,U,4)
  1.  I $P(X,U,5),$D(^DIC(5,$P(X,U,5),0)) W " ",$P($G(^DIC(5,$P(X,U,5),0)),U,2)
  1.  W " ",$P(X,U,6)
  1.  G P3
  1.  ;
  1. P2 ; ---  Patient is not registered.
  1.  I '$$DIE("10:15",2) D END Q       ;EDIT PATIENT INFO NON-REGISTERED
  1.  I $D(^ACHSDEN(DUZ(2),"D",ACHSA,10)),$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,10)),U)]"",'$$DIE("6///N;7///@") D END Q
  1.  ;
  1.  ;
  1. P3 ;
  1.  I $L($$DN^ACHS(0,7))!$L($$DN^ACHS(10,1)) G DEFER  ;IF 'REGISTERED PATIENT
  1.  ;                                                OR 'PATIENT NAME' OKAY
  1.  W !!,*7,"No valid patient has yet been entered - try again.",!!
  1.  G PAT
  1.  ;
  1. DEFER ;
  1.  W !!
  1.  S DIE="^ACHSDEN("_DUZ(2)_",""D"","
  1.  ;IHS/CNI/abk 7/16/10 ACHS*3.1*18
  1.  ;S DR="400//NOT A DEFERRED SERVICE"
  1.  S DR="400//NOT AN UNMET NEED"
  1.  S DA=ACHSA
  1.  D ^DIE               ;DEFERRED SERVICES TYPE
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ EXIT TO PAT LINE
  1.  ;Q:$D(Y)
  1.  G:$D(Y) PAT
  1.  ;
  1. DOS ; ---  Enter Date of Service of Denial.
  1.  ;ACHS*3.1*10 4.21.03 IHS/ITSC/FCJ TEST FOR RCIS CHG PASS OF 4 TO DR VAR
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ ALSO CHG G PAT TO G DEFER
  1.  ;I '$$DIE(4,2) D END Q      ;IF NO 'DATE OF MEDICAL SERVICE' QUIT
  1.  S DR=4,Y=$P(^ACHSDEN(DUZ(2),"D",ACHSA,0),U,4)
  1.  I Y="",$G(ACHSREF) D
  1.  .S Y=$S(ACHSREF(1106)'="":ACHSREF(1106),1:ACHSREF(1105))
  1.  I Y X ^DD("DD") S DR="4//"_Y
  1.  I '$$DIE(DR,2) D END Q      ;IF NO 'DATE OF MEDICAL SERVICE' QUIT
  1.  I $D(Y) K ACHSREF,Y S $P(^ACHSDEN(DUZ(2),"D",ACHSA,0),U,4)="" G DEFER
  1.  S ACHDDOS=$$DN^ACHS(0,4)   ;ACHS*3.1*21
  1.  ;ACHS*3.1*10 4.21.03 IHS/ITSC/FCJ END OF CHANGES
  1.  ;
  1.  ; CHECK IF DATE IS IN ACCEPTABLE RANGE OF 10 YEARS
  1.  S X1=X,X2=DT
  1.  D ^%DTC
  1.  I $TR(X,"-","")>3650 D  G DOS
  1.  . W !!,*7,"DATE OF MEDICAL SERVICE must be within 10 years of today!",!
  1.  . D RTRN^ACHS
  1.  I $$DN^ACHS(0,4)="" W !!,*7,"A DATE OF MEDICAL SERVICE must be entered - try again." W ! D RTRN^ACHS G DOS
  1. DOR ; ---  Enter Date Request Received.
  1.  I '$$DIE(5,2) D END Q
  1.  G DOS:$D(Y)
  1.  ;I $$DN^ACHS(0,5)="" W !!,*7,"A DATE REQUEST RECEIVED must be entered - try again." W ! D RTRN^ACHS G DOR ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ RMVD RTRN
  1.  I $$DN^ACHS(0,5)="" W !!,*7,"A DATE REQUEST RECEIVED must be entered - try again." W ! G DOR ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ RMVD RTRN
  1.  ;
  1.  ;ADD CHS WORKGROUP REQUEST FOR PROMPT TO "SEND THE LETTER TO WHOM"
  1.  ;DEFAULT=PATIENT
  1.  ;ASK IF THERE IS AN ALTERNATE RECIPIENT
  1. ALTREC ;
  1.  ;change next line.  the denial record number is in var ACHSA,
  1.  ;not in A("DA").  1/5/01  PMF
  1.  ;W !! S DR=9,DIE="^ACHSDEN("_DUZ(2)_",""D"",",DA=A("DA") D ^DIE
  1.  W !!
  1.  S DR="9//YES"
  1.  S DIE="^ACHSDEN("_DUZ(2)_",""D"","
  1.  S DA=ACHSA
  1.  D ^DIE
  1.  ;
  1.  G DOR:$D(Y)
  1.  ;
  1.  ;it looks like wanted to set DA, but screwed it up.  also, we
  1.  ;want to take this action if they said N, not Y.   1/5/01  pmf
  1.  ;I X="Y" W !! S DR=9.5,DIE="^ACHSDEN("_DUZ(2)_",""D"",",DA("DA") D ^DIE G ALTREC:$D(Y)
  1.  I X="N" W !! S DR=9.5,DIE="^ACHSDEN("_DUZ(2)_",""D"",",DA=ACHSA D ^DIE G ALTREC:$D(Y)
  1.  ;
  1.  D ^ACHSDN1                     ;SECOND PART OF DENIAL ENTRY
  1.  G:$D(DTOUT)!$D(DUOUT) PAT
  1.  ;ACHS*3.1*13 12.1.06 IHS/OIT/FCJ COULD NOT GET OUT OF LOOP EXT TO PREV CALL
  1.  I ACHSERR S ACHSERR="" G ALTREC
  1.  D ^ACHSDNDP                    ;DISPLAY DENIAL DATA
  1.  D NUMBER                      ;CALCULATE AND SSIGN DENAIL #
  1. END ;
  1.  K A,ACHD,DFN,DTOUT,DUOUT,DIC,DIE,DR,DLAYGO,DA,DIK,ACHDREG
  1.  ;ACHS*3.1*10 4.21.03 IHS/ITSC/FCJ ADDED LN
  1.  K ACHSREF,ACHSERR,ACHSDES,ACHSEDOS,ACHSESDO,ACHSHRN,ACHSPROV,ACHSRMPC,ACHSTYP,ACHDPAT,ACHS,ACHSA,C,Y,Y1,INS  ;ACHS*3.1*10 4.21.03 IHS/ITSC/FCJ ADDED LN
  1.  Q
  1.  ;
  1. KILL ; ---  User stopped before all data entered.  Delete pseudo.
  1.  S DA(1)=DUZ(2),DA=ACHSA,DIK="^ACHSDEN("_DUZ(2)_",""D"","
  1.  D ^DIK
  1.  W !!,*7,"This denial has been deleted.",!!!
  1.  D RTRN^ACHS
  1.  D END
  1.  Q
  1.  ;
  1. NUMBER ; ---  Calculate and assign the Denial Number.
  1.  N ACHDDOS,ACHDFY,ACHDMSG,ACHDNUM,ACHDQTR,ACHDSEQ
  1.  ;
  1.  S ACHDDOS=$$DN^ACHS(0,4)
  1.  S ACHDFY=$$GETFY(ACHDDOS)
  1.  S ACHDQTR=+$E($P($$FY^ACHS(ACHDFY),U),4,5)
  1.  S Y=0
  1.  F X=ACHDQTR:1 S:X=13 X=1 S Y=Y+1 I X=+$E(ACHDDOS,4,5) Q
  1.  S ACHDQTR=$S(Y<4:1,Y<7:2,Y<10:3,1:4)
  1.  I '$$LOCK^ACHS("^ACHSDENR(DUZ(2),4)","+") Q
  1.  S ACHDFY=$S(ACHDFY>50:"19",1:"20")_ACHDFY
  1.  I '$D(^ACHSDENR(DUZ(2),4,ACHDFY,0)) S DIE="^ACHSDENR(",DR="4///"_ACHDFY,DA=DUZ(2),DR(2,9002072.02)=".01///"_ACHDFY D ^DIE
  1.  S ACHDMSG=0
  1. SEQ ;
  1.  S (ACHDSEQ,$P(^ACHSDENR(DUZ(2),4,ACHDFY,0),U,2))=$P($G(^ACHSDENR(DUZ(2),4,ACHDFY,0)),U,2)+1
  1.  S ACHDNUM=$E(ACHDFY,3,4)_ACHDQTR_"-"_ACHD("AREA")_ACHD("FAC")_"-"_ACHDSEQ
  1.  ;
  1.  I $D(^ACHSDEN(DUZ(2),"D","B",ACHDNUM)) S ACHDMSG=ACHDMSG+1 W:ACHDMSG<2 !!,"*** one moment, please ***",!! G SEQ
  1.  I '$$LOCK^ACHS("^ACHSDENR(DUZ(2),4)","-") Q
  1.  ;
  1.  I '$$DIE(".01///"_ACHDNUM_";2////"_DT_";3////"_DUZ) Q
  1.  W @IOF,!!,"This denial has been posted.  The DENIAL NUMBER is: ",ACHDNUM,!!!!
  1.  ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ ADDED NXT LINE TO CLOSE REF
  1.  I $G(ACHSREF) D STAT^ACHSBMC("D") ;ACHS*3.1*10 4.21.04
  1.  D RTRN^ACHS
  1.  Q
  1.  ;
  1. R(C,N) ;
  1.  Q $$REPEAT^XLFSTR(C,N)
  1.  ;
  1. DIE(DR,Z) ;EP - Edit Denial fields.  ACHSA must be the IEN of the Denial.
  1.  I $G(Z) F %=1:1:Z W !
  1.  S DA=ACHSA
  1.  S DA(1)=DUZ(2)
  1.  S DIE="^ACHSDEN("_DUZ(2)_",""D"","
  1.  I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA)","+") S DUOUT="" Q 0
  1.  D ^DIE
  1.  I '$$LOCK^ACHS("^ACHSDEN(DUZ(2),""D"",ACHSA)","-") S DUOUT="" Q 0
  1.  Q 1
  1.  ;
  1. GETFY(X) ;EP - Given date X, return last 2 digits of FY in which it falls.
  1.  N W,Y,Z
  1.  ;
  1.  S Y=$E(DT,1,3)+1700-10
  1.  S Y=$E(Y,3,4)
  1.  ; Fiscal spending authorities are only good for 7 years, that's why
  1.  ; the lookback of only 10 years.
  1.  ;
  1.  ; Check 20 FYs until the date (X) is bracketed in the FY begin and
  1.  ; end dates, returned from FY^ACHS().
  1.  F Z=Y:1:Y+21 S:Z>99 Z=0 S:Z<10 Z="0"_Z S W=$$FY^ACHS(Z) I '(X<$P(W,U)),'(X>$P(W,U,2)) Q
  1.  ;
  1.  I Z=(Y+21) Q -1
  1.  Q Z
  1.  ;