ACHSDNL3 ; IHS/ITSC/PMF - DENIAL LTR/FS (LTR2) (4/6) ;7/23/10 15:32
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,5,6,12,18,21,27**;JUNE 11, 2001;Build 43
;ACHS*3.1*3 prt alt ins, chg chart no display,fx opt prt, allow for a third sig
;ACHS*3.1*4 include effective dates on alt ins and fx left margin
;ACHS*3.1*5 12/06/2002 display of Medicare dt
;ACHS*3.1*6 3.24.03 IHS/SET/FCJ CHECK FOR PRT SUD AND AREA DIR, TEST PROV,ALT RES AND FOR TOT $ AMT TO PRT
;ACHS*3.1*18 6.11.10 IHS/SET/ABK Top, Lft Mar par BC name and phone no
;ACHS*3.1*18 9.31.10 IHS.OIT.FCJ MULT Chng FOR NEW DEN REA AND OPT, EDIT OPT is calling this rtn-ACHSDN4
;ACHS*3.1*27 11.14.17 IHS.OIT.FCJ CHANGE FOR NEW MEDICARE NUMBER
BODY ;EP - Print body of Den let
;CHECK 'PRT DEN AMOUNT ON LETTERS?' PAR
;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD COUNT TEST
I ACHSCNT>0,$P($G(^ACHSDENR(DUZ(2),0)),U,6)="Y" S DA=ACHSA D AMT^ACHSDNA ;ACHS*3.1*6
S ACHSNFAC=$P(^DIC(4,DUZ(2),0),U,1) ;ACHS*3.1*18
A ;
;{ABK, 6/11/10} SET TOPM AND DIWL
S T2=$G(^ACHSDENR(DUZ(2),0)),DIWL=$P(T2,U,9),TOPM=$P(T2,U,11)
S:DIWL="" DIWL=5 S:TOPM="" TOPM=5
;{abk,6/15/10}S DIWL=5,DIWR=75,DIWF="W",ACHD=0,ACHDPRE=""
S DIWR=75,DIWF="W",ACHD=0,ACHDPRE=""
W !!,?DIWL-1,"Dear ",$S($G(ACHDALT)'="N":$G(ACHDNAMP),1:$G(ACHDALTN)),",",!!
;
MIDTXT ; --- Prt Mid Text of Den let
;{ABK, 6/11/10} SET TOPM AND DIWL FROM CHS DENIAL PAR
S T2=$G(^ACHSDENR(DUZ(2),0)),DIWL=$P(T2,U,9),TOPM=$P(T2,U,11)
S:DIWL="" DIWL=5 S:TOPM="" TOPM=5
F S ACHD=$O(^ACHSDENR(DUZ(2),2,ACHD)) Q:+ACHD=0 D Q:$G(ACHSQUIT)
.S X=$G(^ACHSDENR(DUZ(2),2,ACHD,0)) I X["ACHSFAC" S X=$P(X,"ACHSFAC",1)_ACHSNFAC_$P(X,"ACHSFAC",2)
.D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
S DIWF="WI5C55"
;
PRIREAS ;PRIMARY DEN REA?
S ACHDPREN=$G(^ACHSDEN(DUZ(2),"D",ACHSA,250))
I ACHDPREN S ACHDPRE=$P($G(^ACHSDENS($P(ACHDPREN,U),0)),U)
;NO DEN REA AND NO OTHER DEN REA SKIP DOING DEN SECT
I 'ACHDPREN,'$D(^ACHSDEN(DUZ(2),"D",ACHSA,300)) W ?DIWL+10,"(No denial reason on file.)",! G A5
;
PRITXT ;
;ACHS*3.1*18 IHS.OIT.FCJ SPLIT LINE INTO DO AND ADDED NXT LINE
I $P(ACHDPREN,U,3) S ACHDFC=$P(^DIC(4,$P(ACHDPREN,U,3),0),U)
I ACHDPREN W !?DIWL-1,ACHDPRE D
.F ACHD=0:0 S ACHD=$O(^ACHSDENS(+ACHDPREN,1,ACHD)) Q:'ACHD D
..S X=$G(^ACHSDENS(+ACHDPREN,1,ACHD,0))
..D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
;
Q:$G(ACHSQUIT)
D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
S ACHSX=$G(^ACHSDENR(DUZ(2),0)),ACHSDBCN=$P(ACHSX,U,12),ACHSDBCP=$P(ACHSX,U,13) ;ACHS*3.1*18
;
G:'$P(ACHDPREN,U,2) PRICMT
I $D(^ACHSDENS(+ACHDPREN,20,$P(ACHDPREN,U,2),1,1,0)) D Q:$G(ACHSQUIT)
.S ACHD=""
.;ACHS*3.1*18 ACHS*3.1*18 MULT CHANGES SPLIT F LOOP ADDED LINES, ETC
.F S ACHD=$O(^ACHSDENS(+ACHDPREN,20,$P(ACHDPREN,U,2),1,ACHD)) Q:ACHD="" D
..S X=$G(^ACHSDENS(+ACHDPREN,20,$P(ACHDPREN,U,2),1,ACHD,0))
..I X["ACHSDBCN" S X=$P(X,"ACHSDBCN",1)_ACHSDBCN_$P(X,"ACHSDBCN",2) ;ACHS*3.1*18
..I X["ACHSDBCP" S X=$P(X,"ACHSDBCP",1)_ACHSDBCP_$P(X,"ACHSDBCP",2) ;ACHS*3.1*18
..I X["ACHDALT" S X=$P(X,"ACHDALT",1) D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT) D ALTINS Q ;ACHS*3.1*18
..I X["ACHDTY" S X1=$P(X,"ACHDTY",1),X2=$P(X,"ACHDTY",2) D ALTOPT S X=X1_ACHDTY_X2 ;ACHS*3.1*18
..I X["ACHSNFAC" S X=$P(X,"ACHSNFAC",1)_ACHSNFAC_$P(X,"ACHSNFAC",2) ;ACHS*3.1*18
..I X["ACHDFC" S X=$P(X,"ACHDFC",1)_ACHDFC_$P(X,"ACHDFC",2) ;ACHS*3.1*18
..D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
. D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
Q:$G(ACHSQUIT)
;
PRICMT ;
I $D(^ACHSDEN(DUZ(2),"D",ACHSA,255,0)) D Q:$G(ACHSQUIT)
. W !
. S X="Primary Denial Comments:"
. D ^DIWP,^DIWW
. S ACHD=0
. F S ACHD=$O(^ACHSDEN(DUZ(2),"D",ACHSA,255,ACHD)) Q:'ACHD D Q:$G(ACHSQUIT)
..S X=$G(^ACHSDEN(DUZ(2),"D",ACHSA,255,ACHD,0))
..D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
.Q:$G(ACHSQUIT) D ^DIWW
Q:$G(ACHSQUIT)
;
OTHTXT ;OTH DEN REA
S ACHDI=0
;ACHS*3.1*18 MULT CHANGES
F S ACHDI=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI)) Q:+ACHDI=0 I $D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0)) D
.S A=0,DA=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0)),U) D PG:$Y>ACHSBM Q:$G(ACHSQUIT)
.S ACHDO=^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0)
.;WRITE OTH REA
.W !?DIWL-1,$P($G(^ACHSDENS(DA,0)),U) S A=0 D
..;WRITE THE TEXT
..F S A=$O(^ACHSDENS(DA,1,A)) Q:+A=0 S X=$G(^ACHSDENS(DA,1,A,0)) D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
..D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
..;WRITE OPT
..S ACHDOPT=$P(ACHDO,U,2),ACHDFC=$P(ACHDO,U,3)
..I ACHDFC>0 S ACHDFC=$P(^DIC(4,ACHDFC,0),U)
..I ACHDOPT S A=0 F S A=$O(^ACHSDENS(DA,20,ACHDOPT,1,A)) Q:A'?1N.N D
...S X=$G(^ACHSDENS(DA,20,ACHDOPT,1,A,0))
...I X["ACHSDBCN" S X=$P(X,"ACHSDBCN",1)_ACHSDBCN_$P(X,"ACHSDBCN",2) ;ACHS*3.1*18
...I X["ACHSDBCP" S X=$P(X,"ACHSDBCP",1)_ACHSDBCP_$P(X,"ACHSDBCP",2) ;ACHS*3.1*18
...I X["ACHDALT" S X=$P(X,"ACHDALT",1) D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT) D ALTINS Q ;ACHS*3.1*18
...I X["ACHDTY" S X1=$P(X,"ACHDTY",1),X2=$P(X,"ACHDTY",2) D ALTOPT2 S X=X1_ACHDTY_X2 ;ACHS*3.1*18
...I X["ACHDFC" S X=$P(X,"ACHDFC",1)_ACHDFC_$P(X,"ACHDFC",2) ;ACHS*3.1*18
...D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT) ; ACHS*3.1*3
..D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
..D OTHCMT
G A5
;
OTHCMT ;
Q:+ACHDI=0
I $D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,0)) D
. W !
. S X="Other Denial Comments:"
. D ^DIWP,^DIWW
. S ACHDC=0
. F S ACHDC=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,ACHDC)) Q:'ACHDC S X=$G(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,ACHDC,0)) D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
. D ^DIWW,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
Q
;
A5 ;
D PG:$Y>ACHSBM Q:$G(ACHSQUIT)
S ACHD=0,DIWF="W",DIWR=75
;
BOTTXT ; --Prt Bot Text of Den let
W !!
;{ABK, 6/11/10} SET TOPM AND DIWL
S T2=$G(^ACHSDENR(DUZ(2),0)),DIWL=$P(T2,U,9),TOPM=$P(T2,U,11)
S:DIWL="" DIWL=5 S:TOPM="" TOPM=5
S DIWR=75,DIWF="W"
F ACHD=0:0 S ACHD=$O(^ACHSDENR(DUZ(2),3,ACHD)) Q:+ACHD=0 S X=$G(^ACHSDENR(DUZ(2),3,ACHD,0)) D ^DIWP,PG:$Y>ACHSBM Q:$G(ACHSQUIT)
D ^DIWW
D PG:$Y>ACHSBM
Q:$G(ACHSQUIT)
;
;PRT SUD info
I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)'=353610,+$P($G(^AUTTLOC(DUZ(2),0)),U,10)'=353601 D SUD(20)
;
CLOSTXT ; --- Prt closing text
W !!
F ACHD=0:0 S ACHD=$O(^ACHSDENR(DUZ(2),9,ACHD)) Q:+ACHD=0 S X=$G(^ACHSDENR(DUZ(2),9,ACHD,0)) D ^DIWP,PG:(($Y+7)>ACHSBM) Q:$G(ACHSQUIT)
D ^DIWW
;
;
AREADIR ; --- Area Director info
G:$P($G(^ACHSDENR(DUZ(2),200)),U)="" SIGTXT ;ACHS*3.1*6
W !!?20,$P($G(^ACHSDENR(DUZ(2),200)),U)
W !?20,$P($G(^ACHSDENR(DUZ(2),200)),U,2)
S ACHSYAYA=$P($G(^ACHSDENR(DUZ(2),200)),U,8) I ACHSYAYA'="" W !,?20,ACHSYAYA
S ACHSYAYA=$P($G(^ACHSDENR(DUZ(2),200)),U,9) I ACHSYAYA'="" W !,?20,ACHSYAYA
K ACHSYAYA
;
W !?20,$P($G(^ACHSDENR(DUZ(2),200)),U,3),", "
W $P($G(^DIC(5,$P($G(^ACHSDENR(DUZ(2),200)),U,4),0)),U,2)," "
W $P($G(^ACHSDENR(DUZ(2),200)),U,5)
W !?20,$P($G(^ACHSDENR(DUZ(2),200)),U,6),!
;
;
SIGTXT ;
; --- Print sig text
D PG:$Y>(ACHSBM-10) Q:$G(ACHSQUIT)
S DIWF="NW"
W !!
F ACHD=0:0 S ACHD=$O(^ACHSDENR(DUZ(2),7,ACHD)) Q:+ACHD=0 S X=$G(^ACHSDENR(DUZ(2),7,ACHD,0)) D ^DIWP,PG:($Y>ACHSBM) Q:$G(ACHSQUIT)
D ^DIWW
D PG:$Y>ACHSBM
Q:$G(ACHSQUIT)
W !!
;
;sig person ;PRINT SUD INFO
I $D(^ACHSDENR(DUZ(2),300)) D I 1
. N DATA,ZZ F ZZ=300:1:305 S DATA=$G(^ACHSDENR(DUZ(2),ZZ)) I DATA'="" W !,?4,DATA
. S DATA=$G(^ACHSDENR(DUZ(2),306)) I DATA'="" W $P($G(^DIC(5,DATA,0)),U,2)
. S DATA=$G(^ACHSDENR(DUZ(2),307)) I DATA'="" W " ",DATA
. S DATA=$G(^ACHSDENR(DUZ(2),308)) I DATA'="" W !,?4,DATA
E D SUD(4)
I ACHDONE D END Q
;
;
OFC ; --- Print office info at bottom
;11/28/01 pmf changes to include the Pawnee BP #
;W !!!,"Denial Number: ",$$DN^ACHS(0,1),!,"Chart Number: " ; ACHS*3.1*3
;I $G(DFN)'="" D ; ACHS*3.1*3
;.W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)_" "_$P($G(^DIC(4,DUZ(2),0)),U) ; ACHS*3.1*3
;.W:'$D(^AUPNPAT(DFN,41,DUZ(2),0)) "(No Chart At This Facility)" ; ACHS*3.1*3
;E W $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,10)),U,6) ;'CHART # (OTHER FACILITY) ; ACHS*3.1*3
;.Q ; ACHS*3.1*3
W !!!,"Denial Number: ",$$DN^ACHS(0,1) ; ACHS*3.1*3
D SETCHT^ACHSDNL2 ; ACHS*3.1*3
W !,ACHDCH ; ACHS*3.1*3
;
I $$DN^ACHS(850,1)'="Y" W !,"No Receipt Information Available",! G CMT1
;
W !,"Method of receipt: "
S X=$$DN^ACHS(850,2),Y=$P($G(^DD(9002071.01,851,0)),U,3)
F %=1:1 D Q:'%
. I $P(Y,";",%)="" W "<unknown>" S %=0 Q
. I $P($P(Y,";",%),":")=X W $P($P(Y,";",%),":",2) S %=0 Q
. Q
W !,"Date of receipt: ",$$FMTE^XLFDT($$DN^ACHS(850,3))
W !,"Received by: ",$$DN^ACHS(850,4)
CMT1 ;
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,900)) D END Q
W !!,"CHS Office Comments: ",!
S ACHD=0
F S ACHD=$O(^ACHSDEN(DUZ(2),"D",ACHSA,900,ACHD)) Q:'ACHD S X=$G(^ACHSDEN(DUZ(2),"D",ACHSA,900,ACHD,0)) D ^DIWP
D ^DIWW
END ;
Q:$G(ACHSQUIT)
W !!!
I $$DN^ACHS(0,8)="Y" F I=1:1:4 W "DOCUMENT CANCELLED *"
W !!
;
I 'ACHDONE F I=1:1:4 W "*** OFFICE COPY *** "
;
D RTRN^ACHS
W @IOF
K ACHDALT,ACHDI,ACHDPRE,ACHDPREN,ACHDPROV,DA,DTOUT,DUOUT,STATEPRT,SUDSTUFF,ACHSCNT,ACHDO,ACHDOPT,ACHDFC,ACHSNFAC
Q
;
PG ;Heading other than first page.
Q:$G(ACHSQUIT)
D RTRN^ACHS
S ACHSPG=ACHSPG+1
W @IOF,!!!?DIWL-1,ACHDNAMP,?76-$L($$DN^ACHS(0,1)),$$DN^ACHS(0,1),!?70,"Page ",ACHSPG,!!
Q
SUD(OFFSET) ;
Q:$P($G(^ACHSDENR(DUZ(2),100)),U)=""
S SUDSTUFF=$G(^ACHSDENR(DUZ(2),100))
W !?OFFSET,$P(SUDSTUFF,U)
W !?OFFSET,$P(SUDSTUFF,U,2)
I $P(SUDSTUFF,U,8)'="" W !?OFFSET,$P(SUDSTUFF,U,8)
I $P(SUDSTUFF,U,9)'="" W !?OFFSET,$P(SUDSTUFF,U,9)
;
W !?OFFSET,$P(SUDSTUFF,U,3)
W ", "
S STATEPTR=$P($G(^ACHSDENR(DUZ(2),100)),U,4)
W:STATEPTR'="" $P($G(^DIC(5,STATEPTR,0)),U,2)," ",$P($G(^ACHSDENR(DUZ(2),100)),U,5),!?OFFSET,$P($G(^ACHSDENR(DUZ(2),100)),U,6)
D PG:$Y>ACHSBM Q:$G(ACHSQUIT)
Q
;
ALTINS ;
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,320)) Q
I $G(DFN)="" Q
W !
N DAT,DAT1,DAT2,DAT3,SS,TAG
W !,?DIWL+4,"INSURANCE",?31,"ID NO.",?43,"EFF. DATE",?55,"TRM. DATE",!,?DIWL+4 F DAT=1:1 W "-" I $X>64 Q
S SS=0 F S SS=$O(^ACHSDEN(DUZ(2),"D",ACHSA,320,SS)) Q:SS="" D
. S DAT2=$G(^ACHSDEN(DUZ(2),"D",ACHSA,320,SS,0)),DAT=$P(DAT2,U,2)
. S TAG="PINS"_DAT I $L(TAG)=5 D @TAG
W !
Q
;
PINSM ; MEDICARE
;ACHS*3.1*27 REWROTE TO PRINT NEW MBI AND PART "D"
N DATMCR S DATMCR=""
S DAT1=$G(^AUPNMCR(DFN,0))
S DATMCR=$$GETMBI^AUPNMBI(DFN,DT,0)
S DAT2=$P(DAT2,U,3) I DAT2="" Q
S DAT2=$G(^AUPNMCR(DFN,11,DAT2,0))
W !,?DIWL+4,"Medicare"
I $P(DAT2,U,3)?1"D" W ?30,$P($G(DAT2),U,6)
E W ?30,$S(+DATMCR<1:$P(DAT1,U,3),1:$P(DATMCR,U)) I $P(DAT1,U,4),+DATMCR<1 W $G(^AUTTMCS($P(DAT1,U,4),0),U)
W ?42," " S DAT=$P(DAT2,U,1) D PDATE
W ?54," " S DAT=$P(DAT2,U,2) D PDATE
S DATADD=$P(DAT1,U,2)
D:$G(DATADD) PADD
Q
;
PINSC ;MEDICAID
S DAT3=$P(DAT2,U,3)
I DAT3="" Q
W !,?DIWL+4,"Medicaid"
S DAT1=$G(^AUPNMCD(DAT3,0))
W ?30," ",$P(DAT1,U,3)
S DAT2=$P(DAT2,U,4)
I DAT2="" Q
S DAT2=$G(^AUPNMCD(DAT3,11,DAT2,0))
W ?42," " S DAT=$P(DAT2,U,1) D PDATE
W ?54," " S DAT=$P(DAT2,U,2) D PDATE
S DATADD=$P(DAT1,U,10)
D:$G(DATADD) PADD
Q
;
PINSR ;RAILROAD
;ACHS*3.1*27 REWROTE TO PRINT NEW MBI
N DATMCR S DATMCR=""
S DAT1=$G(^AUPNRRE(DFN,0))
S DATMCR=$$GETMBI^AUPNMBI(DFN,DT,0)
S DAT2=$P(DAT2,U,3) I DAT2="" Q ;CHECK FOR ELIG DATES
W !,?DIWL+4,"Railroad Retirement"
I $P(DAT1,U,3),+DATMCR<1 W ?30,$G(^AUTTRRP($P(DAT1,U,3),0),U) ;PRNT PREFIX FOR OLD NUMBER
W ?30,$S(+DATMCR<1:$P(DAT1,U,4),1:$P(DATMCR,U))
S DAT2=$G(^AUPNRRE(DFN,11,DAT2,0))
W ?42," " S DAT=$P(DAT2,U,1) D PDATE
W ?54," " S DAT=$P(DAT2,U,2) D PDATE
S DATADD=$P(DAT1,U,2)
D:$G(DATADD) PADD
Q
;
PINSP ;PRIVATE INS
S DAT=$P(DAT2,U,3),DAT3=$G(^AUPNPRVT(DFN,11,DAT,0))
S DAT=$P(DAT3,U,1) I DAT'="" S DAT=$P($G(^AUTNINS(DAT,0)),U) I DAT="" S DAT=" --- "
W !,?DIWL+4,$E(DAT,1,21),?30," ",$P(DAT2,U,2)
W ?42," " S DAT=$P(DAT3,U,6) D PDATE
W ?54," " S DAT=$P(DAT3,U,7) D PDATE
Q:'$P(DAT3,U) ;ACHS*3.1*18
S DATADD=$G(^AUTNINS($P(DAT3,U),0),0) ;ACHS*3.1*18
W !?DIWL+4,$P(DATADD,U,2)," ",$P(DATADD,U,3),", " I $P(DATADD,U,4) W $P(^DIC(5,$P(DATADD,U,4),0),U,2) ;ACHS*3.1*18
W " ",$P(DATADD,U,5) ;ACHS*3.1*18
Q
;
PDATE ;
;ACHS*3.1*4 new module
I 'DAT Q
W $E(DAT,4,5),"/",$E(DAT,6,7),"/",($E(DAT,1,3)+1700)
Q
PADD ;PRINT INS ADDRESS;ACHS*3.1*18-NEW
;Q:'$P(DAT1,U,2)
S DATADD=$G(^AUTNINS(DATADD,0),0) ;ACHS*3.1*27 CHNG DATADD
W !?DIWL+4,$P(DATADD,U,2)," ",$P(DATADD,U,3),", " I $P(DATADD,U,4) W $P(^DIC(5,$P(DATADD,U,4),0),U,2)
W " ",$P(DATADD,U,5)
Q
ALTOPT ;OPT FOR PRI REASON;ACHS*3.1*18 NEW MODULE
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,256)) Q
S T1="",ACHDTY="",I=0,CT=0,CT1=0
F S I=$O(^ACHSDEN(DUZ(2),"D",ACHSA,256,I)) Q:I'?1N.N S CT=CT+1
S I=0 F S I=$O(^ACHSDEN(DUZ(2),"D",ACHSA,256,I)) Q:I'?1N.N D
.S CT1=CT1+1
.S T=$P(^ACHSDEN(DUZ(2),"D",ACHSA,256,I,0),U)
.I CT>1,CT1>1 S T1=$S(CT1<CT:", ",1:" and ")
.S ACHDTY=ACHDTY_T1_^ACHSDENS(+ACHDPREN,30,T,0)
Q
ALTOPT2 ;OPT FOR OTHER REASON;ACHS*3.1*18 NEW MODULE
I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4)) Q
S T1="",ACHDTY="",I=0,CT=0,CT1=0
F S I=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I)) Q:I'?1N.N S CT=CT+1
S I=0 F S I=$O(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I)) Q:I'?1N.N D
.S CT1=CT1+1
.S T=$P(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I,0),U)
.I CT>1,CT1>1 S T1=$S(CT1<CT:", ",1:" and ")
.S ACHDTY=ACHDTY_T1_^ACHSDENS(DA,30,T,0)
Q
ACHSDNL3 ; IHS/ITSC/PMF - DENIAL LTR/FS (LTR2) (4/6) ;7/23/10 15:32
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,5,6,12,18,21,27**;JUNE 11, 2001;Build 43
+2 ;ACHS*3.1*3 prt alt ins, chg chart no display,fx opt prt, allow for a third sig
+3 ;ACHS*3.1*4 include effective dates on alt ins and fx left margin
+4 ;ACHS*3.1*5 12/06/2002 display of Medicare dt
+5 ;ACHS*3.1*6 3.24.03 IHS/SET/FCJ CHECK FOR PRT SUD AND AREA DIR, TEST PROV,ALT RES AND FOR TOT $ AMT TO PRT
+6 ;ACHS*3.1*18 6.11.10 IHS/SET/ABK Top, Lft Mar par BC name and phone no
+7 ;ACHS*3.1*18 9.31.10 IHS.OIT.FCJ MULT Chng FOR NEW DEN REA AND OPT, EDIT OPT is calling this rtn-ACHSDN4
+8 ;ACHS*3.1*27 11.14.17 IHS.OIT.FCJ CHANGE FOR NEW MEDICARE NUMBER
BODY ;EP - Print body of Den let
+1 ;CHECK 'PRT DEN AMOUNT ON LETTERS?' PAR
+2 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD COUNT TEST
+3 ;ACHS*3.1*6
IF ACHSCNT>0
IF $PIECE($GET(^ACHSDENR(DUZ(2),0)),U,6)="Y"
SET DA=ACHSA
DO AMT^ACHSDNA
+4 ;ACHS*3.1*18
SET ACHSNFAC=$PIECE(^DIC(4,DUZ(2),0),U,1)
A ;
+1 ;{ABK, 6/11/10} SET TOPM AND DIWL
+2 SET T2=$GET(^ACHSDENR(DUZ(2),0))
SET DIWL=$PIECE(T2,U,9)
SET TOPM=$PIECE(T2,U,11)
+3 IF DIWL=""
SET DIWL=5
IF TOPM=""
SET TOPM=5
+4 ;{abk,6/15/10}S DIWL=5,DIWR=75,DIWF="W",ACHD=0,ACHDPRE=""
+5 SET DIWR=75
SET DIWF="W"
SET ACHD=0
SET ACHDPRE=""
+6 WRITE !!,?DIWL-1,"Dear ",$SELECT($GET(ACHDALT)'="N":$GET(ACHDNAMP),1:$GET(ACHDALTN)),",",!!
+7 ;
MIDTXT ; --- Prt Mid Text of Den let
+1 ;{ABK, 6/11/10} SET TOPM AND DIWL FROM CHS DENIAL PAR
+2 SET T2=$GET(^ACHSDENR(DUZ(2),0))
SET DIWL=$PIECE(T2,U,9)
SET TOPM=$PIECE(T2,U,11)
+3 IF DIWL=""
SET DIWL=5
IF TOPM=""
SET TOPM=5
+4 FOR
SET ACHD=$ORDER(^ACHSDENR(DUZ(2),2,ACHD))
IF +ACHD=0
QUIT
Begin DoDot:1
+5 SET X=$GET(^ACHSDENR(DUZ(2),2,ACHD,0))
IF X["ACHSFAC"
SET X=$PIECE(X,"ACHSFAC",1)_ACHSNFAC_$PIECE(X,"ACHSFAC",2)
+6 DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+7 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+8 SET DIWF="WI5C55"
+9 ;
PRIREAS ;PRIMARY DEN REA?
+1 SET ACHDPREN=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,250))
+2 IF ACHDPREN
SET ACHDPRE=$PIECE($GET(^ACHSDENS($PIECE(ACHDPREN,U),0)),U)
+3 ;NO DEN REA AND NO OTHER DEN REA SKIP DOING DEN SECT
+4 IF 'ACHDPREN
IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300))
WRITE ?DIWL+10,"(No denial reason on file.)",!
GOTO A5
+5 ;
PRITXT ;
+1 ;ACHS*3.1*18 IHS.OIT.FCJ SPLIT LINE INTO DO AND ADDED NXT LINE
+2 IF $PIECE(ACHDPREN,U,3)
SET ACHDFC=$PIECE(^DIC(4,$PIECE(ACHDPREN,U,3),0),U)
+3 IF ACHDPREN
WRITE !?DIWL-1,ACHDPRE
Begin DoDot:1
+4 FOR ACHD=0:0
SET ACHD=$ORDER(^ACHSDENS(+ACHDPREN,1,ACHD))
IF 'ACHD
QUIT
Begin DoDot:2
+5 SET X=$GET(^ACHSDENS(+ACHDPREN,1,ACHD,0))
+6 DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:2
End DoDot:1
+7 ;
+8 IF $GET(ACHSQUIT)
QUIT
+9 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+10 ;ACHS*3.1*18
SET ACHSX=$GET(^ACHSDENR(DUZ(2),0))
SET ACHSDBCN=$PIECE(ACHSX,U,12)
SET ACHSDBCP=$PIECE(ACHSX,U,13)
+11 ;
+12 IF '$PIECE(ACHDPREN,U,2)
GOTO PRICMT
+13 IF $DATA(^ACHSDENS(+ACHDPREN,20,$PIECE(ACHDPREN,U,2),1,1,0))
Begin DoDot:1
+14 SET ACHD=""
+15 ;ACHS*3.1*18 ACHS*3.1*18 MULT CHANGES SPLIT F LOOP ADDED LINES, ETC
+16 FOR
SET ACHD=$ORDER(^ACHSDENS(+ACHDPREN,20,$PIECE(ACHDPREN,U,2),1,ACHD))
IF ACHD=""
QUIT
Begin DoDot:2
+17 SET X=$GET(^ACHSDENS(+ACHDPREN,20,$PIECE(ACHDPREN,U,2),1,ACHD,0))
+18 ;ACHS*3.1*18
IF X["ACHSDBCN"
SET X=$PIECE(X,"ACHSDBCN",1)_ACHSDBCN_$PIECE(X,"ACHSDBCN",2)
+19 ;ACHS*3.1*18
IF X["ACHSDBCP"
SET X=$PIECE(X,"ACHSDBCP",1)_ACHSDBCP_$PIECE(X,"ACHSDBCP",2)
+20 ;ACHS*3.1*18
IF X["ACHDALT"
SET X=$PIECE(X,"ACHDALT",1)
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
DO ALTINS
QUIT
+21 ;ACHS*3.1*18
IF X["ACHDTY"
SET X1=$PIECE(X,"ACHDTY",1)
SET X2=$PIECE(X,"ACHDTY",2)
DO ALTOPT
SET X=X1_ACHDTY_X2
+22 ;ACHS*3.1*18
IF X["ACHSNFAC"
SET X=$PIECE(X,"ACHSNFAC",1)_ACHSNFAC_$PIECE(X,"ACHSNFAC",2)
+23 ;ACHS*3.1*18
IF X["ACHDFC"
SET X=$PIECE(X,"ACHDFC",1)_ACHDFC_$PIECE(X,"ACHDFC",2)
+24 DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:2
+25 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+26 IF $GET(ACHSQUIT)
QUIT
+27 ;
PRICMT ;
+1 IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,255,0))
Begin DoDot:1
+2 WRITE !
+3 SET X="Primary Denial Comments:"
+4 DO ^DIWP
DO ^DIWW
+5 SET ACHD=0
+6 FOR
SET ACHD=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,255,ACHD))
IF 'ACHD
QUIT
Begin DoDot:2
+7 SET X=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,255,ACHD,0))
+8 DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:2
IF $GET(ACHSQUIT)
QUIT
+9 IF $GET(ACHSQUIT)
QUIT
DO ^DIWW
End DoDot:1
IF $GET(ACHSQUIT)
QUIT
+10 IF $GET(ACHSQUIT)
QUIT
+11 ;
OTHTXT ;OTH DEN REA
+1 SET ACHDI=0
+2 ;ACHS*3.1*18 MULT CHANGES
+3 FOR
SET ACHDI=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI))
IF +ACHDI=0
QUIT
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0))
Begin DoDot:1
+4 SET A=0
SET DA=$PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0)),U)
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+5 SET ACHDO=^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,0)
+6 ;WRITE OTH REA
+7 WRITE !?DIWL-1,$PIECE($GET(^ACHSDENS(DA,0)),U)
SET A=0
Begin DoDot:2
+8 ;WRITE THE TEXT
+9 FOR
SET A=$ORDER(^ACHSDENS(DA,1,A))
IF +A=0
QUIT
SET X=$GET(^ACHSDENS(DA,1,A,0))
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+10 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+11 ;WRITE OPT
+12 SET ACHDOPT=$PIECE(ACHDO,U,2)
SET ACHDFC=$PIECE(ACHDO,U,3)
+13 IF ACHDFC>0
SET ACHDFC=$PIECE(^DIC(4,ACHDFC,0),U)
+14 IF ACHDOPT
SET A=0
FOR
SET A=$ORDER(^ACHSDENS(DA,20,ACHDOPT,1,A))
IF A'?1N.N
QUIT
Begin DoDot:3
+15 SET X=$GET(^ACHSDENS(DA,20,ACHDOPT,1,A,0))
+16 ;ACHS*3.1*18
IF X["ACHSDBCN"
SET X=$PIECE(X,"ACHSDBCN",1)_ACHSDBCN_$PIECE(X,"ACHSDBCN",2)
+17 ;ACHS*3.1*18
IF X["ACHSDBCP"
SET X=$PIECE(X,"ACHSDBCP",1)_ACHSDBCP_$PIECE(X,"ACHSDBCP",2)
+18 ;ACHS*3.1*18
IF X["ACHDALT"
SET X=$PIECE(X,"ACHDALT",1)
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
DO ALTINS
QUIT
+19 ;ACHS*3.1*18
IF X["ACHDTY"
SET X1=$PIECE(X,"ACHDTY",1)
SET X2=$PIECE(X,"ACHDTY",2)
DO ALTOPT2
SET X=X1_ACHDTY_X2
+20 ;ACHS*3.1*18
IF X["ACHDFC"
SET X=$PIECE(X,"ACHDFC",1)_ACHDFC_$PIECE(X,"ACHDFC",2)
+21 ; ACHS*3.1*3
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:3
+22 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+23 DO OTHCMT
End DoDot:2
End DoDot:1
+24 GOTO A5
+25 ;
OTHCMT ;
+1 IF +ACHDI=0
QUIT
+2 IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,0))
Begin DoDot:1
+3 WRITE !
+4 SET X="Other Denial Comments:"
+5 DO ^DIWP
DO ^DIWW
+6 SET ACHDC=0
+7 FOR
SET ACHDC=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,ACHDC))
IF 'ACHDC
QUIT
SET X=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,1,ACHDC,0))
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+8 DO ^DIWW
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
+9 QUIT
+10 ;
A5 ;
+1 IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+2 SET ACHD=0
SET DIWF="W"
SET DIWR=75
+3 ;
BOTTXT ; --Prt Bot Text of Den let
+1 WRITE !!
+2 ;{ABK, 6/11/10} SET TOPM AND DIWL
+3 SET T2=$GET(^ACHSDENR(DUZ(2),0))
SET DIWL=$PIECE(T2,U,9)
SET TOPM=$PIECE(T2,U,11)
+4 IF DIWL=""
SET DIWL=5
IF TOPM=""
SET TOPM=5
+5 SET DIWR=75
SET DIWF="W"
+6 FOR ACHD=0:0
SET ACHD=$ORDER(^ACHSDENR(DUZ(2),3,ACHD))
IF +ACHD=0
QUIT
SET X=$GET(^ACHSDENR(DUZ(2),3,ACHD,0))
DO ^DIWP
IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+7 DO ^DIWW
+8 IF $Y>ACHSBM
DO PG
+9 IF $GET(ACHSQUIT)
QUIT
+10 ;
+11 ;PRT SUD info
+12 IF +$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)'=353610
IF +$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)'=353601
DO SUD(20)
+13 ;
CLOSTXT ; --- Prt closing text
+1 WRITE !!
+2 FOR ACHD=0:0
SET ACHD=$ORDER(^ACHSDENR(DUZ(2),9,ACHD))
IF +ACHD=0
QUIT
SET X=$GET(^ACHSDENR(DUZ(2),9,ACHD,0))
DO ^DIWP
IF (($Y+7)>ACHSBM)
DO PG
IF $GET(ACHSQUIT)
QUIT
+3 DO ^DIWW
+4 ;
+5 ;
AREADIR ; --- Area Director info
+1 ;ACHS*3.1*6
IF $PIECE($GET(^ACHSDENR(DUZ(2),200)),U)=""
GOTO SIGTXT
+2 WRITE !!?20,$PIECE($GET(^ACHSDENR(DUZ(2),200)),U)
+3 WRITE !?20,$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,2)
+4 SET ACHSYAYA=$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,8)
IF ACHSYAYA'=""
WRITE !,?20,ACHSYAYA
+5 SET ACHSYAYA=$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,9)
IF ACHSYAYA'=""
WRITE !,?20,ACHSYAYA
+6 KILL ACHSYAYA
+7 ;
+8 WRITE !?20,$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,3),", "
+9 WRITE $PIECE($GET(^DIC(5,$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,4),0)),U,2)," "
+10 WRITE $PIECE($GET(^ACHSDENR(DUZ(2),200)),U,5)
+11 WRITE !?20,$PIECE($GET(^ACHSDENR(DUZ(2),200)),U,6),!
+12 ;
+13 ;
SIGTXT ;
+1 ; --- Print sig text
+2 IF $Y>(ACHSBM-10)
DO PG
IF $GET(ACHSQUIT)
QUIT
+3 SET DIWF="NW"
+4 WRITE !!
+5 FOR ACHD=0:0
SET ACHD=$ORDER(^ACHSDENR(DUZ(2),7,ACHD))
IF +ACHD=0
QUIT
SET X=$GET(^ACHSDENR(DUZ(2),7,ACHD,0))
DO ^DIWP
IF ($Y>ACHSBM)
DO PG
IF $GET(ACHSQUIT)
QUIT
+6 DO ^DIWW
+7 IF $Y>ACHSBM
DO PG
+8 IF $GET(ACHSQUIT)
QUIT
+9 WRITE !!
+10 ;
+11 ;sig person ;PRINT SUD INFO
+12 IF $DATA(^ACHSDENR(DUZ(2),300))
Begin DoDot:1
+13 NEW DATA,ZZ
FOR ZZ=300:1:305
SET DATA=$GET(^ACHSDENR(DUZ(2),ZZ))
IF DATA'=""
WRITE !,?4,DATA
+14 SET DATA=$GET(^ACHSDENR(DUZ(2),306))
IF DATA'=""
WRITE $PIECE($GET(^DIC(5,DATA,0)),U,2)
+15 SET DATA=$GET(^ACHSDENR(DUZ(2),307))
IF DATA'=""
WRITE " ",DATA
+16 SET DATA=$GET(^ACHSDENR(DUZ(2),308))
IF DATA'=""
WRITE !,?4,DATA
End DoDot:1
IF 1
+17 IF '$TEST
DO SUD(4)
+18 IF ACHDONE
DO END
QUIT
+19 ;
+20 ;
OFC ; --- Print office info at bottom
+1 ;11/28/01 pmf changes to include the Pawnee BP #
+2 ;W !!!,"Denial Number: ",$$DN^ACHS(0,1),!,"Chart Number: " ; ACHS*3.1*3
+3 ;I $G(DFN)'="" D ; ACHS*3.1*3
+4 ;.W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)_" "_$P($G(^DIC(4,DUZ(2),0)),U) ; ACHS*3.1*3
+5 ;.W:'$D(^AUPNPAT(DFN,41,DUZ(2),0)) "(No Chart At This Facility)" ; ACHS*3.1*3
+6 ;E W $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,10)),U,6) ;'CHART # (OTHER FACILITY) ; ACHS*3.1*3
+7 ;.Q ; ACHS*3.1*3
+8 ; ACHS*3.1*3
WRITE !!!,"Denial Number: ",$$DN^ACHS(0,1)
+9 ; ACHS*3.1*3
DO SETCHT^ACHSDNL2
+10 ; ACHS*3.1*3
WRITE !,ACHDCH
+11 ;
+12 IF $$DN^ACHS(850,1)'="Y"
WRITE !,"No Receipt Information Available",!
GOTO CMT1
+13 ;
+14 WRITE !,"Method of receipt: "
+15 SET X=$$DN^ACHS(850,2)
SET Y=$PIECE($GET(^DD(9002071.01,851,0)),U,3)
+16 FOR %=1:1
Begin DoDot:1
+17 IF $PIECE(Y,";",%)=""
WRITE "<unknown>"
SET %=0
QUIT
+18 IF $PIECE($PIECE(Y,";",%),":")=X
WRITE $PIECE($PIECE(Y,";",%),":",2)
SET %=0
QUIT
+19 QUIT
End DoDot:1
IF '%
QUIT
+20 WRITE !,"Date of receipt: ",$$FMTE^XLFDT($$DN^ACHS(850,3))
+21 WRITE !,"Received by: ",$$DN^ACHS(850,4)
CMT1 ;
+1 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,900))
DO END
QUIT
+2 WRITE !!,"CHS Office Comments: ",!
+3 SET ACHD=0
+4 FOR
SET ACHD=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,900,ACHD))
IF 'ACHD
QUIT
SET X=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,900,ACHD,0))
DO ^DIWP
+5 DO ^DIWW
END ;
+1 IF $GET(ACHSQUIT)
QUIT
+2 WRITE !!!
+3 IF $$DN^ACHS(0,8)="Y"
FOR I=1:1:4
WRITE "DOCUMENT CANCELLED *"
+4 WRITE !!
+5 ;
+6 IF 'ACHDONE
FOR I=1:1:4
WRITE "*** OFFICE COPY *** "
+7 ;
+8 DO RTRN^ACHS
+9 WRITE @IOF
+10 KILL ACHDALT,ACHDI,ACHDPRE,ACHDPREN,ACHDPROV,DA,DTOUT,DUOUT,STATEPRT,SUDSTUFF,ACHSCNT,ACHDO,ACHDOPT,ACHDFC,ACHSNFAC
+11 QUIT
+12 ;
PG ;Heading other than first page.
+1 IF $GET(ACHSQUIT)
QUIT
+2 DO RTRN^ACHS
+3 SET ACHSPG=ACHSPG+1
+4 WRITE @IOF,!!!?DIWL-1,ACHDNAMP,?76-$LENGTH($$DN^ACHS(0,1)),$$DN^ACHS(0,1),!?70,"Page ",ACHSPG,!!
+5 QUIT
SUD(OFFSET) ;
+1 IF $PIECE($GET(^ACHSDENR(DUZ(2),100)),U)=""
QUIT
+2 SET SUDSTUFF=$GET(^ACHSDENR(DUZ(2),100))
+3 WRITE !?OFFSET,$PIECE(SUDSTUFF,U)
+4 WRITE !?OFFSET,$PIECE(SUDSTUFF,U,2)
+5 IF $PIECE(SUDSTUFF,U,8)'=""
WRITE !?OFFSET,$PIECE(SUDSTUFF,U,8)
+6 IF $PIECE(SUDSTUFF,U,9)'=""
WRITE !?OFFSET,$PIECE(SUDSTUFF,U,9)
+7 ;
+8 WRITE !?OFFSET,$PIECE(SUDSTUFF,U,3)
+9 WRITE ", "
+10 SET STATEPTR=$PIECE($GET(^ACHSDENR(DUZ(2),100)),U,4)
+11 IF STATEPTR'=""
WRITE $PIECE($GET(^DIC(5,STATEPTR,0)),U,2)," ",$PIECE($GET(^ACHSDENR(DUZ(2),100)),U,5),!?OFFSET,$PIECE($GET(^ACHSDENR(DUZ(2),100)),U,6)
+12 IF $Y>ACHSBM
DO PG
IF $GET(ACHSQUIT)
QUIT
+13 QUIT
+14 ;
ALTINS ;
+1 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,320))
QUIT
+2 IF $GET(DFN)=""
QUIT
+3 WRITE !
+4 NEW DAT,DAT1,DAT2,DAT3,SS,TAG
+5 WRITE !,?DIWL+4,"INSURANCE",?31,"ID NO.",?43,"EFF. DATE",?55,"TRM. DATE",!,?DIWL+4
FOR DAT=1:1
WRITE "-"
IF $X>64
QUIT
+6 SET SS=0
FOR
SET SS=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,320,SS))
IF SS=""
QUIT
Begin DoDot:1
+7 SET DAT2=$GET(^ACHSDEN(DUZ(2),"D",ACHSA,320,SS,0))
SET DAT=$PIECE(DAT2,U,2)
+8 SET TAG="PINS"_DAT
IF $LENGTH(TAG)=5
DO @TAG
End DoDot:1
+9 WRITE !
+10 QUIT
+11 ;
PINSM ; MEDICARE
+1 ;ACHS*3.1*27 REWROTE TO PRINT NEW MBI AND PART "D"
+2 NEW DATMCR
SET DATMCR=""
+3 SET DAT1=$GET(^AUPNMCR(DFN,0))
+4 SET DATMCR=$$GETMBI^AUPNMBI(DFN,DT,0)
+5 SET DAT2=$PIECE(DAT2,U,3)
IF DAT2=""
QUIT
+6 SET DAT2=$GET(^AUPNMCR(DFN,11,DAT2,0))
+7 WRITE !,?DIWL+4,"Medicare"
+8 IF $PIECE(DAT2,U,3)?1"D"
WRITE ?30,$PIECE($GET(DAT2),U,6)
+9 IF '$TEST
WRITE ?30,$SELECT(+DATMCR<1:$PIECE(DAT1,U,3),1:$PIECE(DATMCR,U))
IF $PIECE(DAT1,U,4)
IF +DATMCR<1
WRITE $GET(^AUTTMCS($PIECE(DAT1,U,4),0),U)
+10 WRITE ?42," "
SET DAT=$PIECE(DAT2,U,1)
DO PDATE
+11 WRITE ?54," "
SET DAT=$PIECE(DAT2,U,2)
DO PDATE
+12 SET DATADD=$PIECE(DAT1,U,2)
+13 IF $GET(DATADD)
DO PADD
+14 QUIT
+15 ;
PINSC ;MEDICAID
+1 SET DAT3=$PIECE(DAT2,U,3)
+2 IF DAT3=""
QUIT
+3 WRITE !,?DIWL+4,"Medicaid"
+4 SET DAT1=$GET(^AUPNMCD(DAT3,0))
+5 WRITE ?30," ",$PIECE(DAT1,U,3)
+6 SET DAT2=$PIECE(DAT2,U,4)
+7 IF DAT2=""
QUIT
+8 SET DAT2=$GET(^AUPNMCD(DAT3,11,DAT2,0))
+9 WRITE ?42," "
SET DAT=$PIECE(DAT2,U,1)
DO PDATE
+10 WRITE ?54," "
SET DAT=$PIECE(DAT2,U,2)
DO PDATE
+11 SET DATADD=$PIECE(DAT1,U,10)
+12 IF $GET(DATADD)
DO PADD
+13 QUIT
+14 ;
PINSR ;RAILROAD
+1 ;ACHS*3.1*27 REWROTE TO PRINT NEW MBI
+2 NEW DATMCR
SET DATMCR=""
+3 SET DAT1=$GET(^AUPNRRE(DFN,0))
+4 SET DATMCR=$$GETMBI^AUPNMBI(DFN,DT,0)
+5 ;CHECK FOR ELIG DATES
SET DAT2=$PIECE(DAT2,U,3)
IF DAT2=""
QUIT
+6 WRITE !,?DIWL+4,"Railroad Retirement"
+7 ;PRNT PREFIX FOR OLD NUMBER
IF $PIECE(DAT1,U,3)
IF +DATMCR<1
WRITE ?30,$GET(^AUTTRRP($PIECE(DAT1,U,3),0),U)
+8 WRITE ?30,$SELECT(+DATMCR<1:$PIECE(DAT1,U,4),1:$PIECE(DATMCR,U))
+9 SET DAT2=$GET(^AUPNRRE(DFN,11,DAT2,0))
+10 WRITE ?42," "
SET DAT=$PIECE(DAT2,U,1)
DO PDATE
+11 WRITE ?54," "
SET DAT=$PIECE(DAT2,U,2)
DO PDATE
+12 SET DATADD=$PIECE(DAT1,U,2)
+13 IF $GET(DATADD)
DO PADD
+14 QUIT
+15 ;
PINSP ;PRIVATE INS
+1 SET DAT=$PIECE(DAT2,U,3)
SET DAT3=$GET(^AUPNPRVT(DFN,11,DAT,0))
+2 SET DAT=$PIECE(DAT3,U,1)
IF DAT'=""
SET DAT=$PIECE($GET(^AUTNINS(DAT,0)),U)
IF DAT=""
SET DAT=" --- "
+3 WRITE !,?DIWL+4,$EXTRACT(DAT,1,21),?30," ",$PIECE(DAT2,U,2)
+4 WRITE ?42," "
SET DAT=$PIECE(DAT3,U,6)
DO PDATE
+5 WRITE ?54," "
SET DAT=$PIECE(DAT3,U,7)
DO PDATE
+6 ;ACHS*3.1*18
IF '$PIECE(DAT3,U)
QUIT
+7 ;ACHS*3.1*18
SET DATADD=$GET(^AUTNINS($PIECE(DAT3,U),0),0)
+8 ;ACHS*3.1*18
WRITE !?DIWL+4,$PIECE(DATADD,U,2)," ",$PIECE(DATADD,U,3),", "
IF $PIECE(DATADD,U,4)
WRITE $PIECE(^DIC(5,$PIECE(DATADD,U,4),0),U,2)
+9 ;ACHS*3.1*18
WRITE " ",$PIECE(DATADD,U,5)
+10 QUIT
+11 ;
PDATE ;
+1 ;ACHS*3.1*4 new module
+2 IF 'DAT
QUIT
+3 WRITE $EXTRACT(DAT,4,5),"/",$EXTRACT(DAT,6,7),"/",($EXTRACT(DAT,1,3)+1700)
+4 QUIT
PADD ;PRINT INS ADDRESS;ACHS*3.1*18-NEW
+1 ;Q:'$P(DAT1,U,2)
+2 ;ACHS*3.1*27 CHNG DATADD
SET DATADD=$GET(^AUTNINS(DATADD,0),0)
+3 WRITE !?DIWL+4,$PIECE(DATADD,U,2)," ",$PIECE(DATADD,U,3),", "
IF $PIECE(DATADD,U,4)
WRITE $PIECE(^DIC(5,$PIECE(DATADD,U,4),0),U,2)
+4 WRITE " ",$PIECE(DATADD,U,5)
+5 QUIT
ALTOPT ;OPT FOR PRI REASON;ACHS*3.1*18 NEW MODULE
+1 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,256))
QUIT
+2 SET T1=""
SET ACHDTY=""
SET I=0
SET CT=0
SET CT1=0
+3 FOR
SET I=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,256,I))
IF I'?1N.N
QUIT
SET CT=CT+1
+4 SET I=0
FOR
SET I=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,256,I))
IF I'?1N.N
QUIT
Begin DoDot:1
+5 SET CT1=CT1+1
+6 SET T=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,256,I,0),U)
+7 IF CT>1
IF CT1>1
SET T1=$SELECT(CT1<CT:", ",1:" and ")
+8 SET ACHDTY=ACHDTY_T1_^ACHSDENS(+ACHDPREN,30,T,0)
End DoDot:1
+9 QUIT
ALTOPT2 ;OPT FOR OTHER REASON;ACHS*3.1*18 NEW MODULE
+1 IF '$DATA(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4))
QUIT
+2 SET T1=""
SET ACHDTY=""
SET I=0
SET CT=0
SET CT1=0
+3 FOR
SET I=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I))
IF I'?1N.N
QUIT
SET CT=CT+1
+4 SET I=0
FOR
SET I=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I))
IF I'?1N.N
QUIT
Begin DoDot:1
+5 SET CT1=CT1+1
+6 SET T=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,300,ACHDI,4,I,0),U)
+7 IF CT>1
IF CT1>1
SET T1=$SELECT(CT1<CT:", ",1:" and ")
+8 SET ACHDTY=ACHDTY_T1_^ACHSDENS(DA,30,T,0)
End DoDot:1
+9 QUIT
