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