ACHSRPU ; IHS/ITSC/PMF - PRINT UNIVERSAL 843 FORMS ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,7,11,12,13,14,15,16,18,19,20,22,23,27**;JUN 11,2001;Build 43
;ITSC/SET/JVK ACHS*3.1*12 12/22/04 add DHHS #
;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ ins fr Pol file, added address, MCD check first entry
;ACHS*3.1*14 9/16/07 IHS.OIT.FCJ E-SIG CHG
; 3/17/08 IHS/OIT/LMH test for pol holder #IM27991 & 28424
;ACHS*3.1*15 12/01/08 IHS.OIT.FCJ FIX MED & contract #
;ACHS*3.1*16 10/23/09 IHS.OIT.FCJ 2 DIG FY
;ACHS*3.1*18 5/20/10;IHS/OIT/ABK Q on for loop
;ACHS*3.1*27 12/12/2017 IHS.OIT.FCJ NEW MBI CHANGES
;
TESTPRNT ;EP. (For test print.)
;ACHS*3.1*16 10/26/09;ACHS*3.1*19 CHG FF SECTION;ACHS*3.1*22 ADDED TEST FOR 585101
S ACHSFF=$S($$ASF^ACHS(DUZ(2))=183052:"!!!!",($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):"!!!!!",1:"!!!!!!!!")
W @ACHSFF
I '$D(ACHSTPRT),"CS"[ACHSTYPE W !!!!!!,"**",$S(ACHSTYPE="C":"CANCELLATION**",1:"PO SUPPLEMENT DATED "_E(11)),"**",!
;W !!!!!!!!
;I '$D(ACHSTPRT),"CS"[ACHSTYPE W "******** ",$S(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
INS ;
;
S ACHSIPRM="N" ;SET PRIMARY INS FLAG
D:'$D(ACHSTPRT) FORMAT ;GET INS INF
S N="" ;INITIALIZE INS SUBSCRIPT
S ACHSBZD=0
;
PONUM ; -- Field 1 : DCR #, Document type, PDO number.
;
U IO ;ACHS*3.1*16 12/01/08 IHS/OIT/FCJ
;ITSC/SET/JVK ACHS*3.1*11 12/22/04
I ACHSORDN'="",ACHSORDN'="9-X99-99999" S ACHSDOFY=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27)
I ACHSORDN="9-X99-99999" S ACHSDOFY="XXXX",ACHSCTYP=1
I ACHSORDN'="",ACHSORDN'="9-X99-99999" S ACHSCTYP=$S($P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),U,9)'="":$P(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9),1:"")
I $D(ACHSCTYP),ACHSCTYP'="" S ACHSCTYP=$P(^ACHSCTYP(ACHSCTYP,0),U,2)
I ACHSORDN="" S ACHSDOFY=ACHSACFY
S ACHSDHHS="HHSI"_$P($G(^ACHSF(DUZ(2),0)),U,11)_ACHSDOFY_$E(ACHSORDN,3,5)_$E(ACHSORDN,7,11)_ACHSCTYP
W ?20,"HHS #:",ACHSDHHS
;PAR-PRINT DCR # ON P.O.
W:$$PARM^ACHS(2,18)="Y" ?ACHSTAB+50,"DCR:",ACHSDCR
;PAR-PRINT 3-DIGIT TYPE ON P.O.
;TYPE # ACHSTYPV FROM MAIN LOOP IN ACHSRP
W ?ACHSTAB+57,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:"")
;;ACHS*3.1*22 ADDED 585101
I $G(ACHSDIEN) S ACHSTAB2=$S(($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):ACHSTAB+64,1:ACHSTAB+61) W ?ACHSTAB2,$E($P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27),3),ACHSORDN,ACHSSF
E W ?ACHSTAB+61,"0",ACHSORDN,ACHSSF ;ORDER NUM , EITHER CANCEL OR SUPPLEMENT NUM
;
NAME ; -- Field 2 : Pat Ident
W !!
;IF BLANKET ORDER SKIP AND GO TO ORDERING FAC
I $D(ACHSBLKF) W !?ACHSTAB,"** BLANKET **" D G ORDFAC
. F %=1:1:7 W ! W:$D(A(%)) ?ACHSTAB,A(%)
;
W ?ACHSTAB,$G(A(2)) ;PAT NAME
;
INSHLD ;Field 3.a. : Name of Pol Holder
I ACHSIPRM="Y" D
.S N=$O(I("P",N))
.S ACHSIPRM=N
.W ?ACHSTAB+55,$E(I(N,1),1,22)
;
PATADRS ;Field 1 : Pat ID
W !
W ?ACHSTAB,$G(A(3)) ;PAT CITY, STATE ZIP
;
INSNM ;Field 3.b. : Plan Name.
I N'="" W:$D(I(N,2)) ?ACHSTAB+49,$E(I(N,2),1,29)
;
SSN ;Field 1 : Pat ID SSN
W !
W ?ACHSTAB,$G(A(11))
;
INSADRS ;Field 3.c. : Insurer's address.
I N'="" W:$D(I(N,3)) ?ACHSTAB+48,I(N,3)
;
W !
;CHECK SSN VER STATUS
SSV ;
;V=VERIFIED BY SSA
;A=SSN ADDED BY SSA
;N=FAC SSN NOT EQUAL TO SSA SSN
;D=SSN MATCHES SSA BUT DATA DIFFERS
;P=PENDING VERIFICATION
;X=SSA COULD NOT VERIFY/SUPPLY SSN
I $G(DFN) S ACHSSSNS=$$SSV^ACHSTX3(DFN) I "PVX"[ACHSSSNS W ?ACHSTAB,ACHSSSNS
;
;Insurer's addrs, cont.
I N'="" W ?ACHSTAB+48,$G(I(N,4))
;
INSPOL ;Field 3.d. : Ins Pol #
W !
I N'="" W ?ACHSTAB+52,$G(I(N,5))
;
FACHRN ;
W !?ACHSTAB,$E($G(A(1)),1,27)
;
INSTYP ;Field 3.e. : Ins Cov Type
I N'="" W ?ACHSTAB+52,$G(I(N,6))
;
AGESEX ;
W !?ACHSTAB,$G(A(4))
;
COMCODE ;
W " ",$G(A(5))
;
INSBDT ;Field 3.f. : Ins Eff Date
W !
I N'="" W ?ACHSTAB+53,$$FMTE^XLFDT($G(I(N,7)))
;
DESC ;
W !?ACHSTAB,"Desc: "
W ?ACHSTAB+6,$G(A(7)) ;WRITE THE DESC
;
INSEDT ;
I N'="",$D(I(N,8)) W ?ACHSTAB+53,$$FMTE^XLFDT(I(N,8)) S N=""
;
ORDFAC ;
;I ($G(B(4))=586212)!($G(B(4))=585101) W ! ;ACHS*3.1*19;ACHS 3.1*22 ADDED 585101
I $G(B(4))=586212 W ! ;ACHS*3.1*19;ACHS 3.1*23
I $G(B(4))=153780 W !!,?ACHSTAB,"PONCA TRIBE OF NEBRASKA" ;IHS.OIT.FCJ ACHS*3.1*19
E W !!?ACHSTAB,$G(B(1)) ;ORD FAC NAME
W ?ACHSTAB+25,"(",$G(B(4)),")" ;ORD FAC NUMBER
;
INSOTH1 ;
S N=$O(I("B",N)) ;MORE OTHER INSURANCE STUFF
S:N=ACHSIPRM N=$O(I("B",N))
W:(N'="") ?ACHSTAB+38,$P(I("B",N),U) ;INSURANCE TYPE
;
ORDADRS1 ;
W !?ACHSTAB,$G(B(2)) ;ORD FAC ADD
;
INSOTH2 ;
I N'="" W ?ACHSTAB+39,$P(I("B",N),U,2) ;INS EFF DT
;
ORDADRS2 ;
W !?ACHSTAB,$G(B(3)) ;ORD FAC ADD
;
INSOTH3 ;OTHER INS BOX 3 h
I N'="" D
.S N=$O(I("B",N))
.I N'="" D
..W ?ACHSTAB+38,$P(I("B",N),U)
..W !?ACHSTAB+39,$P(I("B",N),U,2),!
..S ACHSBZD=ACHSBZD+1
;
BOX567 ;
W:ACHSBZD=0 !! ;NO DATA FOR 3H SKIP LINES
W:ACHSTYPV=1 ?ACHSTAB+11,"X" ;HOSPITAL
W:ACHSTYPV=2 ?ACHSTAB+19,"X" ;DENTAL BOX 5,6,7
W:ACHSTYPV=3 ?ACHSTAB+35,"X" ;OUTPATIENT
;
INSOTH5 ;
I N'="" D
.S N=$O(I("B",N))
.I N'="" D
..W ?ACHSTAB+38,$P(I("B",N),U)
..W !?ACHSTAB+39,$P(I("B",N),U,2),!
..S ACHSBZD=ACHSBZD+1 ;MORE OTHER INSURANCE 3h
;
OPT ;
;W:$D(E(8)) ?ACHSTAB+57,E(8) ;COMMENTS
;
AMT ;
W:ACHSBZD'=2 !!
W !
W:$D(E(9)) ?ACHSTAB+3,E(9) ;EST CHARGES BOX 8
;
CONT ;
;W:$D(F(6)) ?ACHSTAB+57,F(6) ;CONTRACT BOX
;
CAN ;
W:$D(F(7)) ?ACHSTAB+32,F(7) ;CONTRACT ACC # BOX 9
;
OBJ ;
W:$D(F(9)) ?ACHSTAB+62,F(9) ;OCC BOX 10
;
FROMTO ;
W !!
W:$D(C(5)) ?ACHSTAB+20,C(5) ;AUTH FR DT BOX 11
W:$D(R("D",1)) ?ACHSTAB+54,R("D",1) ;DIAG NAR BOX 13
;
REF ;
W !
W:$D(C(6)) ?ACHSTAB+20,C(6) ;AUTH TO DT BOX 11
W:$D(R("D",2)) ?ACHSTAB+39,R("D",2) ;DIAG NAR
W !
W:$D(R("P",1)) ?ACHSTAB+15,R("P",1) ;PROC NAR
W ?ACHSTAB+27,"SCC: ",$G(F(8)) ;SCC
W:$D(R("D",3)) ?ACHSTAB+39,R("D",3)
W !
W:$D(R("P",2)) ?ACHSTAB,R("P",2)
W:$D(R(1)) ?ACHSTAB+55,R(1)
W !
W:$D(R("P",3)) ?ACHSTAB,R("P",3)
W !
W:$D(R("P",4)) ?ACHSTAB,R("P",4)
W:$D(R(2)) ?ACHSTAB+55,R(2)
W !!!
;
RATE ;PRICING INFO SEGMENT
;ITSC/SET/JVK ACHS*3.1*11 PRINT MED PROV #
I ACHSMPP W ?ACHSTAB+49,F(6) G SKIP
;IHS/SET/JVK ACHS*3.1*6 3/20/2003 PRT THE X IN APPROPRIATE BOX OF FORM
I $G(D(10)) W ?ACHSTAB+D(10)-1,"X"
E W ?ACHSTAB+49,"Open Market" G SKIP
G:'$D(D(9)) SKIP
;ACHS*3.1*15 IHS.OIT.FCJ CHG NXT SECT TO PRT CONTRACT # DO NOT USE DEFAULTS FOR TRIBAL SITES
I $P($G(^ACHSF(DUZ(2),0)),U,8)="Y" W ?ACHSTAB+49,D(9) G SKIP ;
I $E(D(9),1,3)'="HHS",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)="HHSI"_ACHSARCO_"-"_D(9) ;ACHS*3.1*15 ADDED HHSI
I $E(D(9),1,3)'="HHS",$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)="HHSI"_"-"_D(9)
;ITSC/SET/JVK ACHS*3.1*12
;W:$D(D(9)) ?ACHSTAB+49,D(9) ;
S ACHSLTH=$L(D(9)) I $E(D(9),ACHSLTH)'="C" S D(9)=D(9)_"C" ;ITSC/SET/JVK ACHS*3.1*12
;I $D(D(9)) S ACHSLTH=$L(D(9)) I $E(D(9),1,3)'="HHS" S D(9)="HHSI"_ACHSARCO_D(9) ;ITSC/SET/JVK ACHS*3.1*13
W:$D(D(9)) ?ACHSTAB+49,D(9) ;
SKIP ;
;I ($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101) W ! ;ACHS*3.1*19;ACHS*3.1*22 585101
I $$ASF^ACHS(DUZ(2))=586212 W ! ;ACHS*3.1*19;ACHS*3.1*23 585101
W !
W:$D(D(11)) ?ACHSTAB+25,D(11)
W !!
;CHANGE PER E-MAILS CONCERNING "Open Market" and "Medicare Rate" string
;being printed when boxes were already X'ed out
I $G(D(12,1))'="" W ?ACHSTAB+D(12,1),"X" ;ACHSMRTI INPATIENT SERVICE
I $G(D(12,2))'="" W ?ACHSTAB+D(12,2),"X" ;ACHSMRTO OUTPATIENT
I $G(D(10))="" W ?ACHSTAB+52,$G(D(13))
;ITSC/SET/JVK ACHS*3.1*11 place an "x" if medicare provider
I ACHSMPP W ?ACHSTAB+22,"X",?ACHSTAB+52,$G(D(13))
W !
W:$D(D(15)) ?ACHSTAB+52,D(15)
SIG ;
;ITSC/SET/JVK ACHS*3.1*7 9/9/2003
;I '$D(ACHSESIG) S ACHSESIG=""
W:ACHSESIG'="" !!?ACHSTAB,ACHSSIG,?ACHSTAB+31,$P(ACHSESIG,",",2)_" "_$P(ACHSESIG,",",1)," E-Signature",?ACHSTAB+66,ACHSEDTE
W:ACHSESIG="" !!?ACHSTAB,ACHSSIG,?ACHSTAB+66,E(7)
W:ACHSASIG'="" !!?ACHSTAB,$P(ACHSASIG,",",2)_" "_$P(ACHSASIG,",",1)," E-Signature",?ACHSTAB+46,ACHSADTE,?ACHSTAB+61,E(9)
PROVIDER ;
;W !!!!!
S ACHSTAB1=$S(($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):1,1:0) ;ACHS*3.1*19;ACHS*3.1*22
W:ACHSASIG="" !! ;ACHS*3.1*14 9.16.07 IHS/OIT/FCJ ADDED LINE FEED
I $$ASF^ACHS(DUZ(2))=202501 W !!
E W !!! ;ACHS*3.1*14 9.16.07 IHS/OIT/FCJ REMOVED LINE FEED
W:$D(D(1)) ?ACHSTAB+7,D(1)
PROTELE ;
W:$D(D(6)) ?ACHSTAB+ACHSTAB1+53,D(6) ;ACHS*3.1*19
PROADRS1 ;
W !
W:$D(D(2)) ?ACHSTAB+7,D(2)
EIN ;
W:$D(D(4)) ?ACHSTAB+47,D(4)
PROADRS2 ;
W !
W:$D(D(3)) ?ACHSTAB+7,D(3)
UPIN ;ACHS*3.1*16 IHS.OIT.FCJ CHANGED UPIN TO DUNS
W:$D(D(8)) ?ACHSTAB+47,D(8)
FAX ;ACHS*3.1*19
W !
W:$D(D("FAX")) ?ACHSTAB+47,"FAX: ",D("FAX")
PROTYPE ;
;I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+9,D(7)
PROCLAS ;
W !
I $D(D(14)) W:D(14)?1N.N ?ACHSTAB+D(14),"X"
W !!!!!!
;
S I=$O(^ACHS(4,0))
W:ACHSDEST="F" ?ACHSTAB+44,$P($G(^ACHS(4,I,0)),U),!,?ACHSTAB,$P($G(^ACHS(4,I,0)),U,2)," ",$P($G(^ACHS(4,I,0)),U,3),",",$P($G(^DIC(5,$P($G(^ACHS(4,I,0)),U,4),0)),U,2)," ",$P($G(^ACHS(4,I,0)),U,5)
W:ACHSDEST="I" ?ACHSTAB+44,B(1),!,?ACHSTAB,B(2)," ",B(3)
W @IOF
KILL ;
;
I '$D(ACHSTPRT),$P(^AUTTLOC(DUZ(2),0),U,10)=202501 Q:ACHSL'=ACHSCPY ;ACHS*3.1*16 10/26/2009 IHS.OIT.FCJ ZUNI MULTIPLE COPIES PATCH
K A,B,C,D,E,F,I,N,R,X
Q
;
FORMAT ;
PVT ;
Q:DFN=""
S (DA,N)=0
G MCR:'$D(^AUPNPRVT(DFN,11))
PVT1 ;
F S DA=$O(^AUPNPRVT(DFN,11,DA)) Q:'DA D
. S N=N+1,ACHSINS=$G(^AUPNPRVT(DFN,11,DA,0))
. D DINAPI
. I ACHSBZD("OK")="N" S N=N-1 Q
. F I=1:1:8 S I(N,I)="" ;ACHS*3.1*14 IHS/FCJ/OIT
. ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ SPLIT NXT LINE-INFO FR POLICY FILE
. ;S I(N,1)=$P(ACHSINS,U,4),I(N,2)=$P(ACHSINS,U),I(N,5)=$P(ACHSINS,U,2),I(N,6)=$P(ACHSINS,U,3),I(N,7)=$P(ACHSINS,U,6),I(N,8)=$P(ACHSINS,U,7)
. S I(N,1)=$P(ACHSINS,U,4),I(N,2)=$P(ACHSINS,U)
. ;ACHS*3.1*14 03/17/08 LMH test for policy holder
. I $P(ACHSINS,U,8)'="",$D(^AUPN3PPH($P(ACHSINS,U,8),0)) D
. .S I(N,5)=$P(^AUPN3PPH($P(ACHSINS,U,8),0),U,4)
. .S I(N,6)=$P(^AUPN3PPH($P(ACHSINS,U,8),0),U,5)
. ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ END OF CHANGES
. S I(N,7)=$P(ACHSINS,U,6),I(N,8)=$P(ACHSINS,U,7)
. S ACHSINS1=^AUTNINS(I(N,2),0),I(N,2)=$P(ACHSINS1,U),I(N,3)=$P(ACHSINS1,U,2) ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ
. I $P(ACHSINS1,U,4),$D(^DIC(5,$P(ACHSINS1,U,4),0)) S X=$P(^(0),U,2),I(N,4)=$P(ACHSINS1,U,3)_", "_X_" "_$P(ACHSINS1,U,5)
. S:$G(I(N,6)) I(N,6)=$P(^AUTTPIC(I(N,6),0),U)
. I (ACHSIPRM="N"),((I(N,8)'<ACHSFDT)!(I(N,8)="")) S ACHSIPRM="Y",I("P",N)="" Q
. S:$G(I(N,7)) I(N,7)=$$FMTE^XLFDT(I(N,7)) ;IHS/OIT/LMH ACHS*3.1*14 6/4/08
. S:$G(I(N,8)) I(N,8)=$$FMTE^XLFDT(I(N,8)) ;IHS/OIT/LMH ACHS*3.1*14 6/4/08
. S I("B",N)=$E(I(N,2),1,(38-$L(I(N,5))))_" "_I(N,5)_"^EFF:"_I(N,7)_" "_I(N,8)
. K I(N)
MCR ;
S N=N+1
G MCD:'$D(^AUPNMCR("B",DFN))
S ACHSMR=N,ACHSMDFN=0,ACHSMDFN=$O(^AUPNMCR("B",DFN,ACHSMDFN)),ACHSINS=$G(^AUPNMCR(ACHSMDFN,0))
;G:$P(ACHSINS,U,3)="" MCD ;ACHS*3.1*27 NEED TO TEST FOR NEW MBI
S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0) ;ACHS*3.1*27
I +ACHSMBI<1 S ACHSMBI=+$P($G(^AUPNMCR(DFN,0)),U,3) S:$P(ACHSINS,U,4)'="" ACHSMBI=ACHSMBI_$P(^AUTTMCS($P(ACHSINS,U,4),0),U) ;ACHS*3.1*27
G:ACHSMBI="" MCD ;ACHS*3.1*27
D DINACK("^AUPNMCR")
G MCD:ACHSBZD("OK")="N"
;
;S I(N,5)=$P(ACHSINS,U,3) ;ACHS*3.1*27
S I(N,5)=ACHSMBI ;ACHS*3.1*27
;S:$P(ACHSINS,U,4)'="" I(N,5)=I(N,5)_$P(^AUTTMCS($P(ACHSINS,U,4),0),U)
S I(N,1)=$S($D(^AUPNMCR(ACHSMDFN,21)):$P(^(21),U),'$D(^(21)):$P($G(^DPT(DFN,0)),U))
D SET("^AUPNMCR")
MCD ;
G RRE:'$D(^AUPNMCD("B",DFN))
;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ rewrote was only checking first med entry
S ACHSMDFN=0,ACHSMR=N
F S ACHSMDFN=$O(^AUPNMCD("B",DFN,ACHSMDFN)) Q:ACHSMDFN'?1N.N D Q:ACHSBZD("OK")="Y"
.D DINACK("^AUPNMCD")
.Q:ACHSBZD("OK")="N"
.S ACHSINS=$G(^AUPNMCD(ACHSMDFN,0)),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
.D SET("^AUPNMCD")
RRE ;
G END:'$D(^AUPNRRE("B",DFN))
S ACHSMDFN=0,ACHSMR=N,ACHSMDFN=$O(^AUPNRRE("B",DFN,ACHSMDFN))
G:ACHSMDFN="" END
;
D DINACK("^AUPNRRE")
G END:ACHSBZD("OK")="N"
S ACHSINS=$G(^AUPNRRE(ACHSMDFN,0)) ;ACHS*3.1*27
S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0) ;ACHS*3.1*27
I +ACHSMBI<1 S ACHSMBI=+$P(ACHSINS,U,4) S:$P(ACHSINS,U,3)'="" ACHSMBI=$P(^AUTTRRP($P(ACHSINS,U,3),0),U)_ACHSMBI ;ACHS*3.1*27
G:ACHSMBI="" END ;ACHS*3.1*27
S I(N,5)=ACHSMBI ;ACHS*3.1*27
S I(N,1)=$S($D(^AUPNRRE(ACHSMDFN,21)):$P(^(21),U),'$D(^(21)):$P($G(^DPT(DFN,0)),U)) ;ACHS*3.1*27
;
;S ACHSINS=$G(^AUPNRRE(ACHSMDFN,0)),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5) ;ACHS*3.1*27
D SET("^AUPNRRE")
END ;
K ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
Q
;
SET(ACHSGL) ;
S:$P(ACHSINS,U,2)'="" I(N,2)=$P($G(^AUTNINS($P(ACHSINS,U,2),0)),U)
S DA=0
F S DA=$O(@ACHSGL@(ACHSMDFN,11,DA)) Q:'DA D ;S N=N+1 dmh commented
. S I(N,6)=$P(@ACHSGL@(ACHSMDFN,11,DA,0),U,3),I(N,7)=$P(^(0),U),I(N,8)=$P(^(0),U,2)
. Q:(ACHSBZD("DT")<I(N,7)) ; -- ACHSBZD("DT") gets set from DINACK
. Q:(I(N,8)'="")&(ACHSBZD("DT")>I(N,8)) ; -- ACHSBZD("DT") gets set from DINACK
. I ACHSIPRM="N" S ACHSIPRM="Y",I("P",N)="" Q
. S I(N,7)=$$FMTE^XLFDT(I(N,7))
. S I(N,8)=$$FMTE^XLFDT(I(N,8))
. S I("B",N)=$E(I(ACHSMR,2),1,(37-$L(I(ACHSMR,5))-$L(I(N,6))))_" "_I(ACHSMR,5)_" "_I(N,6)_"^EFF:"_I(N,7)_" "_I(N,8)
. K:N'=ACHSMR I(N)
. S N=N+1 ;dina moved this to here instead of at SET+3 1/15/97
Q
;
DINACK(ACHSINSZ) ;
;-- Check for elig at DOS Else, no print.
;-- ACHSINSZ contains the name of the ins global.
;
S ACHSBZD("OK")="N"
Q:'$D(C(5))
S X=C(5),%DT=""
D ^%DT
S ACHSBZD("DT")=Y,ACHSBZD("I")=0
;{ABK, 6/10/10}F S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")="" D Q:ACHSBZD("OK")="Y"
F S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")'?1N.N D Q:ACHSBZD("OK")="Y"
. S ACHSBZD("REC")=@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"),0)
. S ACHSBZD("B")=$P(ACHSBZD("REC"),U),ACHSBZD("E")=$P(ACHSBZD("REC"),U,2)
. I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
. I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
Q
;
DINAPI ;-- Check for PI elig at Date Of Service. Else, no print.
S ACHSBZD("OK")="N"
Q:'$D(C(5))
S X=C(5),%DT=""
D ^%DT
S ACHSBZD("DT")=Y
S ACHSBZD("B")=$P(ACHSINS,U,6),ACHSBZD("E")=$P(ACHSINS,U,7)
I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E")) S ACHSBZD("OK")="Y" Q
I (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="") S ACHSBZD("OK")="Y" Q
Q
;
ACHSRPU ; IHS/ITSC/PMF - PRINT UNIVERSAL 843 FORMS ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,7,11,12,13,14,15,16,18,19,20,22,23,27**;JUN 11,2001;Build 43
+2 ;ITSC/SET/JVK ACHS*3.1*12 12/22/04 add DHHS #
+3 ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ ins fr Pol file, added address, MCD check first entry
+4 ;ACHS*3.1*14 9/16/07 IHS.OIT.FCJ E-SIG CHG
+5 ; 3/17/08 IHS/OIT/LMH test for pol holder #IM27991 & 28424
+6 ;ACHS*3.1*15 12/01/08 IHS.OIT.FCJ FIX MED & contract #
+7 ;ACHS*3.1*16 10/23/09 IHS.OIT.FCJ 2 DIG FY
+8 ;ACHS*3.1*18 5/20/10;IHS/OIT/ABK Q on for loop
+9 ;ACHS*3.1*27 12/12/2017 IHS.OIT.FCJ NEW MBI CHANGES
+10 ;
TESTPRNT ;EP. (For test print.)
+1 ;ACHS*3.1*16 10/26/09;ACHS*3.1*19 CHG FF SECTION;ACHS*3.1*22 ADDED TEST FOR 585101
+2 SET ACHSFF=$SELECT($$ASF^ACHS(DUZ(2))=183052:"!!!!",($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):"!!!!!",1:"!!!!!!!!")
+3 WRITE @ACHSFF
+4 IF '$DATA(ACHSTPRT)
IF "CS"[ACHSTYPE
WRITE !!!!!!,"**",$SELECT(ACHSTYPE="C":"CANCELLATION**",1:"PO SUPPLEMENT DATED "_E(11)),"**",!
+5 ;W !!!!!!!!
+6 ;I '$D(ACHSTPRT),"CS"[ACHSTYPE W "******** ",$S(ACHSTYPE="C":"CANCELLATION ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
INS ;
+1 ;
+2 ;SET PRIMARY INS FLAG
SET ACHSIPRM="N"
+3 ;GET INS INF
IF '$DATA(ACHSTPRT)
DO FORMAT
+4 ;INITIALIZE INS SUBSCRIPT
SET N=""
+5 SET ACHSBZD=0
+6 ;
PONUM ; -- Field 1 : DCR #, Document type, PDO number.
+1 ;
+2 ;ACHS*3.1*16 12/01/08 IHS/OIT/FCJ
USE IO
+3 ;ITSC/SET/JVK ACHS*3.1*11 12/22/04
+4 IF ACHSORDN'=""
IF ACHSORDN'="9-X99-99999"
SET ACHSDOFY=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27)
+5 IF ACHSORDN="9-X99-99999"
SET ACHSDOFY="XXXX"
SET ACHSCTYP=1
+6 IF ACHSORDN'=""
IF ACHSORDN'="9-X99-99999"
SET ACHSCTYP=$SELECT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,2)),U,9)'="":$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,2),U,9),1:"")
+7 IF $DATA(ACHSCTYP)
IF ACHSCTYP'=""
SET ACHSCTYP=$PIECE(^ACHSCTYP(ACHSCTYP,0),U,2)
+8 IF ACHSORDN=""
SET ACHSDOFY=ACHSACFY
+9 SET ACHSDHHS="HHSI"_$PIECE($GET(^ACHSF(DUZ(2),0)),U,11)_ACHSDOFY_$EXTRACT(ACHSORDN,3,5)_$EXTRACT(ACHSORDN,7,11)_ACHSCTYP
+10 WRITE ?20,"HHS #:",ACHSDHHS
+11 ;PAR-PRINT DCR # ON P.O.
+12 IF $$PARM^ACHS(2,18)="Y"
WRITE ?ACHSTAB+50,"DCR:",ACHSDCR
+13 ;PAR-PRINT 3-DIGIT TYPE ON P.O.
+14 ;TYPE # ACHSTYPV FROM MAIN LOOP IN ACHSRP
+15 WRITE ?ACHSTAB+57,$SELECT($$PARM^ACHS(2,20)="Y":$SELECT(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:"")
+16 ;;ACHS*3.1*22 ADDED 585101
+17 IF $GET(ACHSDIEN)
SET ACHSTAB2=$SELECT(($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):ACHSTAB+64,1:ACHSTAB+61)
WRITE ?ACHSTAB2,$EXTRACT($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,27),3),ACHSORDN,ACHSSF
+18 ;ORDER NUM , EITHER CANCEL OR SUPPLEMENT NUM
IF '$TEST
WRITE ?ACHSTAB+61,"0",ACHSORDN,ACHSSF
+19 ;
NAME ; -- Field 2 : Pat Ident
+1 WRITE !!
+2 ;IF BLANKET ORDER SKIP AND GO TO ORDERING FAC
+3 IF $DATA(ACHSBLKF)
WRITE !?ACHSTAB,"** BLANKET **"
Begin DoDot:1
+4 FOR %=1:1:7
WRITE !
IF $DATA(A(%))
WRITE ?ACHSTAB,A(%)
End DoDot:1
GOTO ORDFAC
+5 ;
+6 ;PAT NAME
WRITE ?ACHSTAB,$GET(A(2))
+7 ;
INSHLD ;Field 3.a. : Name of Pol Holder
+1 IF ACHSIPRM="Y"
Begin DoDot:1
+2 SET N=$ORDER(I("P",N))
+3 SET ACHSIPRM=N
+4 WRITE ?ACHSTAB+55,$EXTRACT(I(N,1),1,22)
End DoDot:1
+5 ;
PATADRS ;Field 1 : Pat ID
+1 WRITE !
+2 ;PAT CITY, STATE ZIP
WRITE ?ACHSTAB,$GET(A(3))
+3 ;
INSNM ;Field 3.b. : Plan Name.
+1 IF N'=""
IF $DATA(I(N,2))
WRITE ?ACHSTAB+49,$EXTRACT(I(N,2),1,29)
+2 ;
SSN ;Field 1 : Pat ID SSN
+1 WRITE !
+2 WRITE ?ACHSTAB,$GET(A(11))
+3 ;
INSADRS ;Field 3.c. : Insurer's address.
+1 IF N'=""
IF $DATA(I(N,3))
WRITE ?ACHSTAB+48,I(N,3)
+2 ;
+3 WRITE !
+4 ;CHECK SSN VER STATUS
SSV ;
+1 ;V=VERIFIED BY SSA
+2 ;A=SSN ADDED BY SSA
+3 ;N=FAC SSN NOT EQUAL TO SSA SSN
+4 ;D=SSN MATCHES SSA BUT DATA DIFFERS
+5 ;P=PENDING VERIFICATION
+6 ;X=SSA COULD NOT VERIFY/SUPPLY SSN
+7 IF $GET(DFN)
SET ACHSSSNS=$$SSV^ACHSTX3(DFN)
IF "PVX"[ACHSSSNS
WRITE ?ACHSTAB,ACHSSSNS
+8 ;
+9 ;Insurer's addrs, cont.
+10 IF N'=""
WRITE ?ACHSTAB+48,$GET(I(N,4))
+11 ;
INSPOL ;Field 3.d. : Ins Pol #
+1 WRITE !
+2 IF N'=""
WRITE ?ACHSTAB+52,$GET(I(N,5))
+3 ;
FACHRN ;
+1 WRITE !?ACHSTAB,$EXTRACT($GET(A(1)),1,27)
+2 ;
INSTYP ;Field 3.e. : Ins Cov Type
+1 IF N'=""
WRITE ?ACHSTAB+52,$GET(I(N,6))
+2 ;
AGESEX ;
+1 WRITE !?ACHSTAB,$GET(A(4))
+2 ;
COMCODE ;
+1 WRITE " ",$GET(A(5))
+2 ;
INSBDT ;Field 3.f. : Ins Eff Date
+1 WRITE !
+2 IF N'=""
WRITE ?ACHSTAB+53,$$FMTE^XLFDT($GET(I(N,7)))
+3 ;
DESC ;
+1 WRITE !?ACHSTAB,"Desc: "
+2 ;WRITE THE DESC
WRITE ?ACHSTAB+6,$GET(A(7))
+3 ;
INSEDT ;
+1 IF N'=""
IF $DATA(I(N,8))
WRITE ?ACHSTAB+53,$$FMTE^XLFDT(I(N,8))
SET N=""
+2 ;
ORDFAC ;
+1 ;I ($G(B(4))=586212)!($G(B(4))=585101) W ! ;ACHS*3.1*19;ACHS 3.1*22 ADDED 585101
+2 ;ACHS*3.1*19;ACHS 3.1*23
IF $GET(B(4))=586212
WRITE !
+3 ;IHS.OIT.FCJ ACHS*3.1*19
IF $GET(B(4))=153780
WRITE !!,?ACHSTAB,"PONCA TRIBE OF NEBRASKA"
+4 ;ORD FAC NAME
IF '$TEST
WRITE !!?ACHSTAB,$GET(B(1))
+5 ;ORD FAC NUMBER
WRITE ?ACHSTAB+25,"(",$GET(B(4)),")"
+6 ;
INSOTH1 ;
+1 ;MORE OTHER INSURANCE STUFF
SET N=$ORDER(I("B",N))
+2 IF N=ACHSIPRM
SET N=$ORDER(I("B",N))
+3 ;INSURANCE TYPE
IF (N'="")
WRITE ?ACHSTAB+38,$PIECE(I("B",N),U)
+4 ;
ORDADRS1 ;
+1 ;ORD FAC ADD
WRITE !?ACHSTAB,$GET(B(2))
+2 ;
INSOTH2 ;
+1 ;INS EFF DT
IF N'=""
WRITE ?ACHSTAB+39,$PIECE(I("B",N),U,2)
+2 ;
ORDADRS2 ;
+1 ;ORD FAC ADD
WRITE !?ACHSTAB,$GET(B(3))
+2 ;
INSOTH3 ;OTHER INS BOX 3 h
+1 IF N'=""
Begin DoDot:1
+2 SET N=$ORDER(I("B",N))
+3 IF N'=""
Begin DoDot:2
+4 WRITE ?ACHSTAB+38,$PIECE(I("B",N),U)
+5 WRITE !?ACHSTAB+39,$PIECE(I("B",N),U,2),!
+6 SET ACHSBZD=ACHSBZD+1
End DoDot:2
End DoDot:1
+7 ;
BOX567 ;
+1 ;NO DATA FOR 3H SKIP LINES
IF ACHSBZD=0
WRITE !!
+2 ;HOSPITAL
IF ACHSTYPV=1
WRITE ?ACHSTAB+11,"X"
+3 ;DENTAL BOX 5,6,7
IF ACHSTYPV=2
WRITE ?ACHSTAB+19,"X"
+4 ;OUTPATIENT
IF ACHSTYPV=3
WRITE ?ACHSTAB+35,"X"
+5 ;
INSOTH5 ;
+1 IF N'=""
Begin DoDot:1
+2 SET N=$ORDER(I("B",N))
+3 IF N'=""
Begin DoDot:2
+4 WRITE ?ACHSTAB+38,$PIECE(I("B",N),U)
+5 WRITE !?ACHSTAB+39,$PIECE(I("B",N),U,2),!
+6 ;MORE OTHER INSURANCE 3h
SET ACHSBZD=ACHSBZD+1
End DoDot:2
End DoDot:1
+7 ;
OPT ;
+1 ;W:$D(E(8)) ?ACHSTAB+57,E(8) ;COMMENTS
+2 ;
AMT ;
+1 IF ACHSBZD'=2
WRITE !!
+2 WRITE !
+3 ;EST CHARGES BOX 8
IF $DATA(E(9))
WRITE ?ACHSTAB+3,E(9)
+4 ;
CONT ;
+1 ;W:$D(F(6)) ?ACHSTAB+57,F(6) ;CONTRACT BOX
+2 ;
CAN ;
+1 ;CONTRACT ACC # BOX 9
IF $DATA(F(7))
WRITE ?ACHSTAB+32,F(7)
+2 ;
OBJ ;
+1 ;OCC BOX 10
IF $DATA(F(9))
WRITE ?ACHSTAB+62,F(9)
+2 ;
FROMTO ;
+1 WRITE !!
+2 ;AUTH FR DT BOX 11
IF $DATA(C(5))
WRITE ?ACHSTAB+20,C(5)
+3 ;DIAG NAR BOX 13
IF $DATA(R("D",1))
WRITE ?ACHSTAB+54,R("D",1)
+4 ;
REF ;
+1 WRITE !
+2 ;AUTH TO DT BOX 11
IF $DATA(C(6))
WRITE ?ACHSTAB+20,C(6)
+3 ;DIAG NAR
IF $DATA(R("D",2))
WRITE ?ACHSTAB+39,R("D",2)
+4 WRITE !
+5 ;PROC NAR
IF $DATA(R("P",1))
WRITE ?ACHSTAB+15,R("P",1)
+6 ;SCC
WRITE ?ACHSTAB+27,"SCC: ",$GET(F(8))
+7 IF $DATA(R("D",3))
WRITE ?ACHSTAB+39,R("D",3)
+8 WRITE !
+9 IF $DATA(R("P",2))
WRITE ?ACHSTAB,R("P",2)
+10 IF $DATA(R(1))
WRITE ?ACHSTAB+55,R(1)
+11 WRITE !
+12 IF $DATA(R("P",3))
WRITE ?ACHSTAB,R("P",3)
+13 WRITE !
+14 IF $DATA(R("P",4))
WRITE ?ACHSTAB,R("P",4)
+15 IF $DATA(R(2))
WRITE ?ACHSTAB+55,R(2)
+16 WRITE !!!
+17 ;
RATE ;PRICING INFO SEGMENT
+1 ;ITSC/SET/JVK ACHS*3.1*11 PRINT MED PROV #
+2 IF ACHSMPP
WRITE ?ACHSTAB+49,F(6)
GOTO SKIP
+3 ;IHS/SET/JVK ACHS*3.1*6 3/20/2003 PRT THE X IN APPROPRIATE BOX OF FORM
+4 IF $GET(D(10))
WRITE ?ACHSTAB+D(10)-1,"X"
+5 IF '$TEST
WRITE ?ACHSTAB+49,"Open Market"
GOTO SKIP
+6 IF '$DATA(D(9))
GOTO SKIP
+7 ;ACHS*3.1*15 IHS.OIT.FCJ CHG NXT SECT TO PRT CONTRACT # DO NOT USE DEFAULTS FOR TRIBAL SITES
+8 ;
IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,8)="Y"
WRITE ?ACHSTAB+49,D(9)
GOTO SKIP
+9 ;ACHS*3.1*15 ADDED HHSI
IF $EXTRACT(D(9),1,3)'="HHS"
IF '$FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(D(9),1,3))
SET D(9)="HHSI"_ACHSARCO_"-"_D(9)
+10 IF $EXTRACT(D(9),1,3)'="HHS"
IF $FIND("235^239^241^242^243^244^245^246^247^248^249^285",$EXTRACT(D(9),1,3))
SET D(9)="HHSI"_"-"_D(9)
+11 ;ITSC/SET/JVK ACHS*3.1*12
+12 ;W:$D(D(9)) ?ACHSTAB+49,D(9) ;
+13 ;ITSC/SET/JVK ACHS*3.1*12
SET ACHSLTH=$LENGTH(D(9))
IF $EXTRACT(D(9),ACHSLTH)'="C"
SET D(9)=D(9)_"C"
+14 ;I $D(D(9)) S ACHSLTH=$L(D(9)) I $E(D(9),1,3)'="HHS" S D(9)="HHSI"_ACHSARCO_D(9) ;ITSC/SET/JVK ACHS*3.1*13
+15 ;
IF $DATA(D(9))
WRITE ?ACHSTAB+49,D(9)
SKIP ;
+1 ;I ($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101) W ! ;ACHS*3.1*19;ACHS*3.1*22 585101
+2 ;ACHS*3.1*19;ACHS*3.1*23 585101
IF $$ASF^ACHS(DUZ(2))=586212
WRITE !
+3 WRITE !
+4 IF $DATA(D(11))
WRITE ?ACHSTAB+25,D(11)
+5 WRITE !!
+6 ;CHANGE PER E-MAILS CONCERNING "Open Market" and "Medicare Rate" string
+7 ;being printed when boxes were already X'ed out
+8 ;ACHSMRTI INPATIENT SERVICE
IF $GET(D(12,1))'=""
WRITE ?ACHSTAB+D(12,1),"X"
+9 ;ACHSMRTO OUTPATIENT
IF $GET(D(12,2))'=""
WRITE ?ACHSTAB+D(12,2),"X"
+10 IF $GET(D(10))=""
WRITE ?ACHSTAB+52,$GET(D(13))
+11 ;ITSC/SET/JVK ACHS*3.1*11 place an "x" if medicare provider
+12 IF ACHSMPP
WRITE ?ACHSTAB+22,"X",?ACHSTAB+52,$GET(D(13))
+13 WRITE !
+14 IF $DATA(D(15))
WRITE ?ACHSTAB+52,D(15)
SIG ;
+1 ;ITSC/SET/JVK ACHS*3.1*7 9/9/2003
+2 ;I '$D(ACHSESIG) S ACHSESIG=""
+3 IF ACHSESIG'=""
WRITE !!?ACHSTAB,ACHSSIG,?ACHSTAB+31,$PIECE(ACHSESIG,",",2)_" "_$PIECE(ACHSESIG,",",1)," E-Signature",?ACHSTAB+66,ACHSEDTE
+4 IF ACHSESIG=""
WRITE !!?ACHSTAB,ACHSSIG,?ACHSTAB+66,E(7)
+5 IF ACHSASIG'=""
WRITE !!?ACHSTAB,$PIECE(ACHSASIG,",",2)_" "_$PIECE(ACHSASIG,",",1)," E-Signature",?ACHSTAB+46,ACHSADTE,?ACHSTAB+61,E(9)
PROVIDER ;
+1 ;W !!!!!
+2 ;ACHS*3.1*19;ACHS*3.1*22
SET ACHSTAB1=$SELECT(($$ASF^ACHS(DUZ(2))=586212)!($$ASF^ACHS(DUZ(2))=585101):1,1:0)
+3 ;ACHS*3.1*14 9.16.07 IHS/OIT/FCJ ADDED LINE FEED
IF ACHSASIG=""
WRITE !!
+4 IF $$ASF^ACHS(DUZ(2))=202501
WRITE !!
+5 ;ACHS*3.1*14 9.16.07 IHS/OIT/FCJ REMOVED LINE FEED
IF '$TEST
WRITE !!!
+6 IF $DATA(D(1))
WRITE ?ACHSTAB+7,D(1)
PROTELE ;
+1 ;ACHS*3.1*19
IF $DATA(D(6))
WRITE ?ACHSTAB+ACHSTAB1+53,D(6)
PROADRS1 ;
+1 WRITE !
+2 IF $DATA(D(2))
WRITE ?ACHSTAB+7,D(2)
EIN ;
+1 IF $DATA(D(4))
WRITE ?ACHSTAB+47,D(4)
PROADRS2 ;
+1 WRITE !
+2 IF $DATA(D(3))
WRITE ?ACHSTAB+7,D(3)
UPIN ;ACHS*3.1*16 IHS.OIT.FCJ CHANGED UPIN TO DUNS
+1 IF $DATA(D(8))
WRITE ?ACHSTAB+47,D(8)
FAX ;ACHS*3.1*19
+1 WRITE !
+2 IF $DATA(D("FAX"))
WRITE ?ACHSTAB+47,"FAX: ",D("FAX")
PROTYPE ;
+1 ;I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+9,D(7)
PROCLAS ;
+1 WRITE !
+2 IF $DATA(D(14))
IF D(14)?1N.N
WRITE ?ACHSTAB+D(14),"X"
+3 WRITE !!!!!!
+4 ;
+5 SET I=$ORDER(^ACHS(4,0))
+6 IF ACHSDEST="F"
WRITE ?ACHSTAB+44,$PIECE($GET(^ACHS(4,I,0)),U),!,?ACHSTAB,$PIECE($GET(^ACHS(4,I,0)),U,2)," ",$PIECE($GET(^ACHS(4,I,0)),U,3),",",$PIECE($GET(^DIC(5,$PIECE($GET(^ACHS(4,I,0)),U,4),0)),U,2)," ",$PIECE($GET(^ACHS(4,I,0)),U,5)
+7 IF ACHSDEST="I"
WRITE ?ACHSTAB+44,B(1),!,?ACHSTAB,B(2)," ",B(3)
+8 WRITE @IOF
KILL ;
+1 ;
+2 ;ACHS*3.1*16 10/26/2009 IHS.OIT.FCJ ZUNI MULTIPLE COPIES PATCH
IF '$DATA(ACHSTPRT)
IF $PIECE(^AUTTLOC(DUZ(2),0),U,10)=202501
IF ACHSL'=ACHSCPY
QUIT
+3 KILL A,B,C,D,E,F,I,N,R,X
+4 QUIT
+5 ;
FORMAT ;
PVT ;
+1 IF DFN=""
QUIT
+2 SET (DA,N)=0
+3 IF '$DATA(^AUPNPRVT(DFN,11))
GOTO MCR
PVT1 ;
+1 FOR
SET DA=$ORDER(^AUPNPRVT(DFN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+2 SET N=N+1
SET ACHSINS=$GET(^AUPNPRVT(DFN,11,DA,0))
+3 DO DINAPI
+4 IF ACHSBZD("OK")="N"
SET N=N-1
QUIT
+5 ;ACHS*3.1*14 IHS/FCJ/OIT
FOR I=1:1:8
SET I(N,I)=""
+6 ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ SPLIT NXT LINE-INFO FR POLICY FILE
+7 ;S I(N,1)=$P(ACHSINS,U,4),I(N,2)=$P(ACHSINS,U),I(N,5)=$P(ACHSINS,U,2),I(N,6)=$P(ACHSINS,U,3),I(N,7)=$P(ACHSINS,U,6),I(N,8)=$P(ACHSINS,U,7)
+8 SET I(N,1)=$PIECE(ACHSINS,U,4)
SET I(N,2)=$PIECE(ACHSINS,U)
+9 ;ACHS*3.1*14 03/17/08 LMH test for policy holder
+10 IF $PIECE(ACHSINS,U,8)'=""
IF $DATA(^AUPN3PPH($PIECE(ACHSINS,U,8),0))
Begin DoDot:2
+11 SET I(N,5)=$PIECE(^AUPN3PPH($PIECE(ACHSINS,U,8),0),U,4)
+12 SET I(N,6)=$PIECE(^AUPN3PPH($PIECE(ACHSINS,U,8),0),U,5)
End DoDot:2
+13 ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ END OF CHANGES
+14 SET I(N,7)=$PIECE(ACHSINS,U,6)
SET I(N,8)=$PIECE(ACHSINS,U,7)
+15 ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ
SET ACHSINS1=^AUTNINS(I(N,2),0)
SET I(N,2)=$PIECE(ACHSINS1,U)
SET I(N,3)=$PIECE(ACHSINS1,U,2)
+16 IF $PIECE(ACHSINS1,U,4)
IF $DATA(^DIC(5,$PIECE(ACHSINS1,U,4),0))
SET X=$PIECE(^(0),U,2)
SET I(N,4)=$PIECE(ACHSINS1,U,3)_", "_X_" "_$PIECE(ACHSINS1,U,5)
+17 IF $GET(I(N,6))
SET I(N,6)=$PIECE(^AUTTPIC(I(N,6),0),U)
+18 IF (ACHSIPRM="N")
IF ((I(N,8)'<ACHSFDT)!(I(N,8)=""))
SET ACHSIPRM="Y"
SET I("P",N)=""
QUIT
+19 ;IHS/OIT/LMH ACHS*3.1*14 6/4/08
IF $GET(I(N,7))
SET I(N,7)=$$FMTE^XLFDT(I(N,7))
+20 ;IHS/OIT/LMH ACHS*3.1*14 6/4/08
IF $GET(I(N,8))
SET I(N,8)=$$FMTE^XLFDT(I(N,8))
+21 SET I("B",N)=$EXTRACT(I(N,2),1,(38-$LENGTH(I(N,5))))_" "_I(N,5)_"^EFF:"_I(N,7)_" "_I(N,8)
+22 KILL I(N)
End DoDot:1
MCR ;
+1 SET N=N+1
+2 IF '$DATA(^AUPNMCR("B",DFN))
GOTO MCD
+3 SET ACHSMR=N
SET ACHSMDFN=0
SET ACHSMDFN=$ORDER(^AUPNMCR("B",DFN,ACHSMDFN))
SET ACHSINS=$GET(^AUPNMCR(ACHSMDFN,0))
+4 ;G:$P(ACHSINS,U,3)="" MCD ;ACHS*3.1*27 NEED TO TEST FOR NEW MBI
+5 ;ACHS*3.1*27
SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+6 ;ACHS*3.1*27
IF +ACHSMBI<1
SET ACHSMBI=+$PIECE($GET(^AUPNMCR(DFN,0)),U,3)
IF $PIECE(ACHSINS,U,4)'=""
SET ACHSMBI=ACHSMBI_$PIECE(^AUTTMCS($PIECE(ACHSINS,U,4),0),U)
+7 ;ACHS*3.1*27
IF ACHSMBI=""
GOTO MCD
+8 DO DINACK("^AUPNMCR")
+9 IF ACHSBZD("OK")="N"
GOTO MCD
+10 ;
+11 ;S I(N,5)=$P(ACHSINS,U,3) ;ACHS*3.1*27
+12 ;ACHS*3.1*27
SET I(N,5)=ACHSMBI
+13 ;S:$P(ACHSINS,U,4)'="" I(N,5)=I(N,5)_$P(^AUTTMCS($P(ACHSINS,U,4),0),U)
+14 SET I(N,1)=$SELECT($DATA(^AUPNMCR(ACHSMDFN,21)):$PIECE(^(21),U),'$DATA(^(21)):$PIECE($GET(^DPT(DFN,0)),U))
+15 DO SET("^AUPNMCR")
MCD ;
+1 IF '$DATA(^AUPNMCD("B",DFN))
GOTO RRE
+2 ;ACHS*3.1*13 11/17/06 IHS/OIT/FCJ rewrote was only checking first med entry
+3 SET ACHSMDFN=0
SET ACHSMR=N
+4 FOR
SET ACHSMDFN=$ORDER(^AUPNMCD("B",DFN,ACHSMDFN))
IF ACHSMDFN'?1N.N
QUIT
Begin DoDot:1
+5 DO DINACK("^AUPNMCD")
+6 IF ACHSBZD("OK")="N"
QUIT
+7 SET ACHSINS=$GET(^AUPNMCD(ACHSMDFN,0))
SET I(N,5)=$PIECE(ACHSINS,U,3)
SET I(N,1)=$PIECE(ACHSINS,U,5)
+8 DO SET("^AUPNMCD")
End DoDot:1
IF ACHSBZD("OK")="Y"
QUIT
RRE ;
+1 IF '$DATA(^AUPNRRE("B",DFN))
GOTO END
+2 SET ACHSMDFN=0
SET ACHSMR=N
SET ACHSMDFN=$ORDER(^AUPNRRE("B",DFN,ACHSMDFN))
+3 IF ACHSMDFN=""
GOTO END
+4 ;
+5 DO DINACK("^AUPNRRE")
+6 IF ACHSBZD("OK")="N"
GOTO END
+7 ;ACHS*3.1*27
SET ACHSINS=$GET(^AUPNRRE(ACHSMDFN,0))
+8 ;ACHS*3.1*27
SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+9 ;ACHS*3.1*27
IF +ACHSMBI<1
SET ACHSMBI=+$PIECE(ACHSINS,U,4)
IF $PIECE(ACHSINS,U,3)'=""
SET ACHSMBI=$PIECE(^AUTTRRP($PIECE(ACHSINS,U,3),0),U)_ACHSMBI
+10 ;ACHS*3.1*27
IF ACHSMBI=""
GOTO END
+11 ;ACHS*3.1*27
SET I(N,5)=ACHSMBI
+12 ;ACHS*3.1*27
SET I(N,1)=$SELECT($DATA(^AUPNRRE(ACHSMDFN,21)):$PIECE(^(21),U),'$DATA(^(21)):$PIECE($GET(^DPT(DFN,0)),U))
+13 ;
+14 ;S ACHSINS=$G(^AUPNRRE(ACHSMDFN,0)),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5) ;ACHS*3.1*27
+15 DO SET("^AUPNRRE")
END ;
+1 KILL ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
+2 QUIT
+3 ;
SET(ACHSGL) ;
+1 IF $PIECE(ACHSINS,U,2)'=""
SET I(N,2)=$PIECE($GET(^AUTNINS($PIECE(ACHSINS,U,2),0)),U)
+2 SET DA=0
+3 ;S N=N+1 dmh commented
FOR
SET DA=$ORDER(@ACHSGL@(ACHSMDFN,11,DA))
IF 'DA
QUIT
Begin DoDot:1
+4 SET I(N,6)=$PIECE(@ACHSGL@(ACHSMDFN,11,DA,0),U,3)
SET I(N,7)=$PIECE(^(0),U)
SET I(N,8)=$PIECE(^(0),U,2)
+5 ; -- ACHSBZD("DT") gets set from DINACK
IF (ACHSBZD("DT")<I(N,7))
QUIT
+6 ; -- ACHSBZD("DT") gets set from DINACK
IF (I(N,8)'="")&(ACHSBZD("DT")>I(N,8))
QUIT
+7 IF ACHSIPRM="N"
SET ACHSIPRM="Y"
SET I("P",N)=""
QUIT
+8 SET I(N,7)=$$FMTE^XLFDT(I(N,7))
+9 SET I(N,8)=$$FMTE^XLFDT(I(N,8))
+10 SET I("B",N)=$EXTRACT(I(ACHSMR,2),1,(37-$LENGTH(I(ACHSMR,5))-$LENGTH(I(N,6))))_" "_I(ACHSMR,5)_" "_I(N,6)_"^EFF:"_I(N,7)_" "_I(N,8)
+11 IF N'=ACHSMR
KILL I(N)
+12 ;dina moved this to here instead of at SET+3 1/15/97
SET N=N+1
End DoDot:1
+13 QUIT
+14 ;
DINACK(ACHSINSZ) ;
+1 ;-- Check for elig at DOS Else, no print.
+2 ;-- ACHSINSZ contains the name of the ins global.
+3 ;
+4 SET ACHSBZD("OK")="N"
+5 IF '$DATA(C(5))
QUIT
+6 SET X=C(5)
SET %DT=""
+7 DO ^%DT
+8 SET ACHSBZD("DT")=Y
SET ACHSBZD("I")=0
+9 ;{ABK, 6/10/10}F S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")="" D Q:ACHSBZD("OK")="Y"
+10 FOR
SET ACHSBZD("I")=$ORDER(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I")))
IF ACHSBZD("I")'?1N.N
QUIT
Begin DoDot:1
+11 SET ACHSBZD("REC")=@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"),0)
+12 SET ACHSBZD("B")=$PIECE(ACHSBZD("REC"),U)
SET ACHSBZD("E")=$PIECE(ACHSBZD("REC"),U,2)
+13 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E"))
SET ACHSBZD("OK")="Y"
QUIT
+14 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="")
SET ACHSBZD("OK")="Y"
QUIT
End DoDot:1
IF ACHSBZD("OK")="Y"
QUIT
+15 QUIT
+16 ;
DINAPI ;-- Check for PI elig at Date Of Service. Else, no print.
+1 SET ACHSBZD("OK")="N"
+2 IF '$DATA(C(5))
QUIT
+3 SET X=C(5)
SET %DT=""
+4 DO ^%DT
+5 SET ACHSBZD("DT")=Y
+6 SET ACHSBZD("B")=$PIECE(ACHSINS,U,6)
SET ACHSBZD("E")=$PIECE(ACHSINS,U,7)
+7 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("DT")'>ACHSBZD("E"))
SET ACHSBZD("OK")="Y"
QUIT
+8 IF (ACHSBZD("DT")'<ACHSBZD("B"))&(ACHSBZD("E")="")
SET ACHSBZD("OK")="Y"
QUIT
+9 QUIT
+10 ;
