ACHSRPU.m

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)