2:42 PM  18-DEC-97
ACHS*3*1 ADD SCC TO PRINTOUT OF PO
ACHSRP3
ACHSRP3 ; IHS/ADC/GTH - PRINT CHS (43 & 64) FORMS (1/2) ; [ 11/20/97  1:24 PM ]
 ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997
 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 ;
 S T=0,E(8)=ACHSCOPT,ACHSSF="",LS=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2)
 S:+LS>0 ACHSSF="S"_LS
 S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA
 I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
 D KILLNULS
TESTPRNT ;EP.  (For test print.)
PONUM ;
 W:'T !
 W !?ACHSTAB+53,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+60+$S(ACHSTYPV=1:2,1:0),"0",ACHSORDN,ACHSSF
DCR ;
 I $$PARM^ACHS(2,18)="Y" W " (",ACHSDCR,")"
ORDOFF ;
 W !!?ACHSTAB+42+T,B(1)
FACHRN ;
 W !
 W:$D(A(1)) ?ACHSTAB,A(1)
ORDADRS1 ;
 W:$D(B(2)) ?ACHSTAB+42+T,B(2)
NAME ;
 W !
 W:$D(A(2)) ?ACHSTAB,A(2)
SSV ;
 I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+28,X
ORDADRS2 ;
 W:$D(B(3)) ?ACHSTAB+42+T,B(3)
SUCODE ;
 W:$D(B(4)) ?69,"(",B(4),")"
PATADRS ;
 W !
 W:$D(A(3)) ?ACHSTAB,A(3)
AGESEX ;
 W !?ACHSTAB
 W:$D(A(4)) A(4),"    "
COMCODE ;
 W:$D(A(5)) A(5)
PROVIDER ;
 W:$D(D(1)) ?ACHSTAB+42+T,D(1)
PROADRS1 ;
 W !
 W:$D(D(2)) ?ACHSTAB+42+T,D(2)
 W !
DOS ;
 W:$D(A(6)) ?ACHSTAB,A(6)
PROADRS2 ;
 W:$D(D(3)) ?ACHSTAB+42+T,D(3)
FROMTO ;
 W !
 W:$D(C(4)) ?ACHSTAB,C(4)
PTYPE ;
 I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+39+T,D(7)
EIN ;
 W:$D(D(4)) ?ACHSTAB+42+T,D(4)
DESC ;
 W !
 W:$D(A(7)) ?ACHSTAB,A(7)
 S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
 I F(6)'["Open Market",'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(F(6),1,3)) S F(6)=ACHSARCO_"-"_F(6)
CNTCANOB ;
 ; W ! ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 W !?ACHSTAB,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 S:T T=2
 F I=6,7,9 W ?ACHSTAB+$P("^^^^^42^58^^67",U,I)+T,F(I) I T S T=T-1
 W !!!?ACHSTAB,ACHSSIG
 S T=$S(ACHSTYPV=1:"32^41^62^70",1:"32^41^52^62")
DTOPTAMT ;
 F I=7:1:9 W:$D(E(I)) ?ACHSTAB+$P(T,U,I-6),E(I) I I=8,ACHSTYPV=1 W ?ACHSTAB+54,ACHSESDA
HSPORDNO ;
 W:$D(E(10)) ?ACHSTAB+$P(T,U,4),E(10)
 W !!!!!!!!!!!
 S I=$O(^ACHS(4,0))
 G CSUPL:ACHSDEST'="F",CSUPL:'I,CSUPL:'$D(^ACHS(4,I,0))
 W ?20,"PLEASE MAIL IHS-",$S(ACHSTYPV=1:"43",ACHSTYPV=3:"64",1:"")," AND COMPLETED HCFA-",$S(ACHSTYPV=1:"1450",ACHSTYPV=3:"1500",1:"")," TO:",!!?25,$P(^ACHS(4,I,0),U) W:$P(^(0),U,6)]"" !?25,$P(^(0),U,6)
 W !?25,$P(^ACHS(4,I,0),U,2),!?25,$P(^(0),U,3)
 W ", ",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2),"  ",$P(^ACHS(4,I,0),U,5)
CSUPL ;
 I ACHSTYPE="C"!(ACHSTYPE="S") D CSUPLA G END
 G END:$D(ACHSTPRT)!'$D(A(9))
 D ^ACHSRP31
END ;
 W @IOF
 Q
 ;
CSUPLA ;EP.
 S ACHSTYPE="********   "_$S(ACHSTYPE="C":"CANCELLATION   ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
 W !!
 F I=1:1:5 W ?25,ACHSTYPE,! I I=4,ACHSTYPE["CANCEL" S ACHSTYPE="CANCELLATION DATE "_$$FMTE^XLFDT($$TRAN^ACHS(0,1))
 Q
 ;
KILLNULS ;EP.
 F ACHSX="A","B","C","D","E","F" F ACHSY=1:1:12 S ACHS=ACHSX_"("_ACHSY_")" I $D(@ACHS),'$L(@ACHS) K @ACHS
 KILL ACHSX,ACHSY
 Q
 ;

ACHSRP3D
ACHSRP3D ; IHS/ADC/GTH - PRINT CHS (57 - DENTAL) FORMS ; [ 12/18/97  2:41 PM ]
 ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997
 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 ;
 S ACHSSF="",LS=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,6),ACHSLCA=$P(^(0),U,7),ACHSTYPE=$P(^(0),U,2)
 S:LS ACHSSF="S"_LS
 S:ACHSLCA ACHSSF="C"_ACHSLCA
 I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
 D KILLNULS^ACHSRP3
TESTPRNT ;EP.
 F I=1:1:ACHSTOPM W !
FACHRN ;
 W !
 W:$D(A(1)) ?ACHSTAB,$E(A(1),1,28)
FROMTO ;
 W:$D(C(4)) ?ACHSTAB+38,C(4)
PONUM ;
 W ?ACHSTAB+54,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+62,"0",ACHSORDN,ACHSSF
NAME ;
 W !
 W:$D(A(2)) ?ACHSTAB,A(2)
DCR ;
 I $$PARM^ACHS(2,18)="Y" W ?ACHSTAB+67,"(",ACHSDCR,")"
PTADRS ;
 W !
 W:$D(A(3)) ?ACHSTAB,A(3)
SIG ;
 W ?ACHSTAB+37,ACHSSIG
DT ;
 W ?ACHSTAB+64,E(7)
DOBSEX ;
 W !?ACHSTAB
 W:$D(A(4)) A(4)
COMCODE ;
 W:$D(A(5)) "   ",A(5)
ORDOFF ;
 W !?ACHSTAB+37,$E(B(1),1,25)
SUCODE ;
 W ?ACHSTAB+64,B(4)
AGESEX ;
 W !?ACHSTAB+2
 W:$D(A(4)) $E(A(4),1,8),?ACHSTAB+26,$E(A(4),11)
ORDADRS ;
 W:$D(B(3)) ?ACHSTAB+37,B(3)
DEST ;
 W:$D(D(5)) ?ACHSTAB+64,D(5)
SSV ;
 W !
 I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB+11,X
SSN ;
 W !?ACHSTAB+11
 W:$D(A(11)) A(11)
PROV ;
 W ?ACHSTAB+37,$E(D(1),1,23)
PTYPE ;
 I $$PARM^ACHS(2,17)="Y",$D(D(7)) W $S($X<60:" ",1:""),D(7)
EIN ;
 I $D(D(4)) S D(4)=$P(D(4)," ",1) W ?ACHSTAB+62,D(4)
PADRS ;
 W:$D(D(2)) !?ACHSTAB+48,$E(D(2),1,30)
 W:$D(D(3)) !?ACHSTAB+48,$E(D(3),1,30)
CANOBJ ;
 ; W !?10,$S('$D(ACHSTPRT):$P(^ACHS(2,ACHSCAN,0),U)_"  "_$P(^ACHS(3,DUZ(2),1,ACHSSCC,0),U),1:"J123456  99.9Z") ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 W !?10,$S('$D(ACHSTPRT):F(7)_"  "_F(9)_" SCC: "_F(8),1:"J123456  99.9Z") ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
DESC ;
 W !
 W:$D(A(7)) ?ACHSTAB,A(7)
CONTNO ;
 W !
 W:$D(F(6)) ?19,F(6)
OBLGAMT ;
 W ?ACHSTAB+38,E(9)
 I $D(ACHSTPRT) G END
REFTYPE ;
 W !!!!!!
 S ACHSLREF=$E($P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,11)_$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),U,10))
 I $L(ACHSLREF) F I=3:1:7 W !?ACHSTAB+18,$P($T(@ACHSLREF),";",I)
 I ACHSTYPE="C"!(ACHSTYPE="S") W !!!!!!! D CSUPLA^ACHSRP3 G END
 F  Q:$Y=44  W !
MCR ;
 G NO3:'$D(A(9)),MCD:'$D(^AUPNMCR(DFN,0)),MCD:'$P(^(0),U,3)
 W !?ACHSTAB+15,"MCR:",$P(^AUPNMCR(DFN,0),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0)) W $P(^(0),U)
 S J=0
 F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I  S:I>J J=I
 I J W ":",$P(^AUPNMCR(DFN,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
MCD ;
 G RRE:'$D(^AUPNMCD("B",DFN))
 F R=0:0 S R=$O(^AUPNMCD("B",DFN,R)) Q:'R  S X=R
 W !?ACHSTAB+$S($Y=45:15,1:0),"MCD:",$P(^AUPNMCD(X,0),U,3) I $P(^(0),U,4),$D(^DIC(5,$P(^(0),U,4),0)) W $P(^(0),U,2)
 S J=0
 F I=0:0 S I=$O(^AUPNMCD(X,11,I)) Q:+I'=I  S:I>J J=I
 I J W ":",$P(^AUPNMCD(X,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
RRE ;
 G PVT:'$D(^AUPNRRE(DFN,0))
 W:$Y=44 !
 W ?$S($Y=45:ACHSTAB+15,$X'>ACHSTAB:ACHSTAB,1:$X+5),"RRR:" W:$P(^AUPNRRE(DFN,0),U,3) $P(^AUTTRRP($P(^(0),U,3),0),U) W $P(^AUPNRRE(DFN,0),U,4)
 S J=0
 F  S J=$O(^AUPNRRE(DFN,11,J)) Q:J'?1N.N  D
 . W ":",$P(^AUPNRRE(DFN,11,J,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
 .Q
 W !
PVT ;
 G NO3:'$D(^AUPNPRVT(DFN,11)),NO3:'$O(^(11,0))
 W:$Y=44 !
 F I=0:0 S I=$O(^AUPNPRVT(DFN,11,I)) Q:'I  W ?ACHSTAB+$S($Y=45:15,1:0),$E($P(^AUTNINS($P(^(I,0),U),0),U),1,8),":",$P(^AUPNPRVT(DFN,11,I,0),U,2),":",$P(^(0),U,3),":",$E($P(^(0),U,6),2,7),":",$E($P(^(0),U,7),2,7),"  " W:$X>50 !
NO3 ;
 W:$Y=44 !?ACHSTAB+15,"THIRD PARTY RESOURCES: NONE"
END ;
 W @IOF
 KILL ACHSLREF
 Q
 ;
G ;;GENERAL REFERRAL: Before providing services other than;examination, radiographs, or emergency services, this;claim form must be returned for predetermination.
E ;;SPECIFIC REFERRAL, TYPE E:  Emergency examination and;treatment not to exceed above obligation.  Services;limited to Levels I-III of the IHS Schedule of Oral;Health Services.
B ;;SPECIFIC REFERRAL, TYPE B:  Examination and treatment;limited to Levels I-III of the IHS Schedule of Oral;Health Services.  Treatment plans exceeding $300 must;be returned for predetermination.
S ;;SPECIFIC REFERRAL, TYPE S:  Specialty Services:  Services;limited to *_____________, not to exceed above obligation.;;*In the above blank, give a brief description of the;services ordered, including ADA code(s), if possible.
L ;;REFERRAL TYPE L:  Authorization for dental laboratory;services for fabrication of _________________________.

ACHSRPU
ACHSRPU ; IHS/ADC/GTH - PRINT UNIVERSAL 843 FORMS ; [ 11/20/97  1:44 PM ]
 ;;3.0;CONTRACT HEALTH MGMT SYSTEM;**1**;SEP 17, 1997
 ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 ;
 ;  Print info from PDO onto Universal PDO form (IHS-843).
 ;
 S E(8)=ACHSCOPT,ACHSSF="",ACHSTYPE=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U,2),ACHSLCA=$P(^(0),U,7),%=$P(^(0),U,6)
 S:+%>0 ACHSSF="S"_%
 S:+ACHSLCA>0 ACHSSF="C"_ACHSLCA
 I ACHSTYPE="S" S E(11)=E(7),X=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0),U),E(7)=$E(X,4,5)_"-"_$E(X,6,7)_"-"_$E(X,2,3)
 D KILLNULS^ACHSRP3
TESTPRNT ;EP.  (For test print.)
 W !!!!!!!!
 I '$D(ACHSTPRT),"CS"[ACHSTYPE W "********   ",$S(ACHSTYPE="C":"CANCELLATION   ********",1:"SUPPLEMENT TO P.O. DATED "_E(11))
INS ;
 S ACHSIPRM="N"
 D:'$D(ACHSTPRT) FORMAT
 S N="",X=0,ACHSBZD=0
PONUM ; -- Field 1 : DCR #, Document type, PDO number.
 W:$$PARM^ACHS(2,18)="Y" ?ACHSTAB+50,"DCR:",ACHSDCR
 W ?ACHSTAB+57,$S($$PARM^ACHS(2,20)="Y":$S(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+61,"0",ACHSORDN,ACHSSF
NAME ; -- Field 2 : Patient Identification.
 W !!
 I $D(ACHSBLKF) W !?ACHSTAB,"** BLANKET **" D  G ORDFAC
 . F %=1:1:7 W ! W:$D(A(%)) ?ACHSTAB,A(%)
 .Q
 I $D(A(2)) W ?ACHSTAB,A(2)
INSHLD ; -- Field 3.a. : Name of Policy Holder.
 I ACHSIPRM="Y" S N=$O(I("P",N)),ACHSIPRM=N W ?ACHSTAB+55,$E(I(N,1),1,22)
PATADRS ; -- Field 1 : Patient Identification.
 W !
 I $D(A(3)) W ?ACHSTAB,A(3)
INSNM ; -- Field 3.b. : Plan Name.
 I N'="" W:$D(I(N,2)) ?ACHSTAB+49,$E(I(N,2),1,29)
SSN ; -- Field 1 : Patient Identification, SSN.
 W !
 I $D(A(11)) W ?ACHSTAB,A(11)
INSADRS ; -- Field 3.c. : Insurer's address.
 I N'="" W:$D(I(N,3)) ?ACHSTAB+48,I(N,3)
SSV ;
 W !
 I $G(DFN) S X=$$SSV^ACHSTX3(DFN) I "PVX"[X W ?ACHSTAB,X
 ; -- Insurer's addrs, cont.
 I N'="" W:$D(I(N,4)) ?ACHSTAB+48,I(N,4)
INSPOL ; -- Field 3.d. : Insurer's Policy Number.
 W !
 I N'="" W:$D(I(N,5)) ?ACHSTAB+52,I(N,5)
FACHRN ;
 W !
 I $D(A(1)) W ?ACHSTAB,$E(A(1),1,27)
INSTYP ; -- Field 3.e. : Insurer's Coverage Type.
 I N'="" W:$D(I(N,6)) ?ACHSTAB+52,I(N,6)
AGESEX ;
 W !
 I $D(A(4)) W ?ACHSTAB,A(4)
COMCODE ;
 I $D(A(5)) W "    ",A(5)
INSBDT ; -- Field 3.f. : Insurer's Effective Date.
 W !
 I N'="",$D(I(N,7)) W ?ACHSTAB+53,$$FMTE^XLFDT(I(N,7))
DESC ;
 W !?ACHSTAB,"Desc: "
 I '$D(ACHSBLKF),$D(A(7)) W ?ACHSTAB+6,A(7)
INSEDT ;
 I N'="",$D(I(N,8)) W ?ACHSTAB+53,$$FMTE^XLFDT(I(N,8)) S N=""
ORDFAC ;
 W !!?ACHSTAB,B(1)
 W:$D(B(4)) ?ACHSTAB+25,"(",B(4),")"
INSOTH1 ;
 S N=$O(I("B",N))
 S:N=ACHSIPRM N=$O(I("B",N))
 W:(N'="") ?ACHSTAB+38,$P(I("B",N),U)
ORDADRS1 ;
 W !
 W:$D(B(2)) ?ACHSTAB,B(2)
INSOTH2 ;
 I N'="" W ?ACHSTAB+39,$P(I("B",N),U,2)
ORDADRS2 ;
 W !
 W:$D(B(3)) ?ACHSTAB,B(3)
INSOTH3 ;
 I N'="" S N=$O(I("B",N)) I N'="" W ?ACHSTAB+38,$P(I("B",N),U),!,?ACHSTAB+39,$P(I("B",N),U,2),! S ACHSBZD=ACHSBZD+1
 W:ACHSBZD=0 !!
 W:ACHSTYPV=1 ?ACHSTAB+11,"X"
 W:ACHSTYPV=2 ?ACHSTAB+19,"X"
 W:ACHSTYPV=3 ?ACHSTAB+35,"X"
INSOTH5 ;
 I N'="" S N=$O(I("B",N)) I N'="" W ?ACHSTAB+38,$P(I("B",N),U),!,?ACHSTAB+39,$P(I("B",N),U,2),! S ACHSBZD=ACHSBZD+1
OPT ;
 ;W:$D(E(8)) ?ACHSTAB+57,E(8) ;COMMENTS
AMT ;
 W:ACHSBZD'=2 !!
 W !
 W:$D(E(9)) ?ACHSTAB+3,E(9)
CONT ;
 ;W:$D(F(6)) ?ACHSTAB+57,F(6) ;CONTRACT
CAN ;
 W:$D(F(7)) ?ACHSTAB+32,F(7)
OBJ ;
 W:$D(F(9)) ?ACHSTAB+62,F(9)
FROMTO ;
 W !!
 W:$D(C(5)) ?ACHSTAB+20,C(5)
 W:$D(R("D",1)) ?ACHSTAB+54,R("D",1)
REF ;
 W !
 W:$D(C(6)) ?ACHSTAB+20,C(6)
 W:$D(R("D",2)) ?ACHSTAB+39,R("D",2)
 W !
 W:$D(R("P",1)) ?ACHSTAB+15,R("P",1)
 W ?ACHSTAB+27,"SCC: ",$G(F(8)) ; ACHS*3*1 IHS/ADC/GTH 11-20-97 Printing SCC had been removed.
 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 ;
 I $D(D(10)) W ?ACHSTAB+D(10)-1,"X" ;dmh chg to +D(10)-1 instead of +D(10) 11-27-96
 ;W:'$D(D(9)) ?ACHSTAB+49,"OPEN MARKET"
 ;W:$D(D(9)) ?ACHSTAB+49,D(9)
 I $D(F(6)),F(6)="Open Market" W ?ACHSTAB+49,F(6) G SKIP
 I $D(D(9)),'$F("235^239^241^242^243^244^245^246^247^248^249^285",$E(D(9),1,3)) S D(9)=ACHSARCO_"-"_D(9)
 W:$D(D(9)) ?ACHSTAB+49,D(9)
SKIP ;
 W !
 W:$D(D(11)) ?ACHSTAB+25,D(11)
 W !!
 W:$D(D(12)) ?ACHSTAB+D(12),"X"
 W:$D(D(13)) ?ACHSTAB+52,D(13)
 W !
 W:$D(D(15)) ?ACHSTAB+52,D(15)
SIG ;
 W !!?ACHSTAB,ACHSSIG,?ACHSTAB+66,E(7)
PROVIDER ;
 W !!!!!
 W:$D(D(1)) ?ACHSTAB+7,D(1)
PROTELE ;
 W:$D(D(6)) ?ACHSTAB+53,D(6)
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 ;
 W:$D(D(8)) ?ACHSTAB+47,D(8)
PROTYPE ;
 ;I $$PARM^ACHS(2,17)="Y",$D(D(7)) W ?ACHSTAB+9,D(7)
PROCLAS ;
 I $D(D(14)) W !! W:D(14)?1N.N ?ACHSTAB+D(14),"X"
 W !!!!!!
 S I=$O(^ACHS(4,0))
 W:ACHSDEST="F" ?ACHSTAB+44,$P(^ACHS(4,I,0),U),!,?ACHSTAB,$P(^(0),U,2)," ",$P(^(0),U,3),",",$P(^DIC(5,$P(^ACHS(4,I,0),U,4),0),U,2)," ",$P(^ACHS(4,I,0),U,5)
 W:ACHSDEST="I" ?ACHSTAB+44,B(1),!,?ACHSTAB,B(2)," ",B(3)
 W @IOF
KILL ;
 KILL 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=^AUPNPRVT(DFN,11,DA,0)
 . D DINAPI
 . I ACHSBZD("OK")="N" S N=N-1 Q
 . 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 ACHSINS1=$P(^AUTNINS(I(N,2),0),U),I(N,2)=$P(ACHSINS1,U),I(N,3)=$P(ACHSINS1,U,2)
 . 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)
 . I I(N,6)'="" S 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 I(N,7)=$$FMTE^XLFDT(I(N,7))
 . S I(N,8)=$$FMTE^XLFDT(I(N,8))
 . 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)
 .Q
MCR ;
 S N=N+1
 G MCD:'$D(^AUPNMCR("B",DFN))
 S ACHSMR=N,ACHSMDFN=0,ACHSMDFN=$O(^AUPNMCR("B",DFN,ACHSMDFN)),ACHSINS=^AUPNMCR(ACHSMDFN,0)
 G:$P(ACHSINS,U,3)="" MCD
 D DINACK("^AUPNMCR")
 G MCD:ACHSBZD("OK")="N"
 ;
 S I(N,5)=$P(ACHSINS,U,3)
 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(^DPT(DFN,0),U))
 D SET("^AUPNMCR")
MCD ;
 G RRE:'$D(^AUPNMCD("B",DFN))
 S ACHSMDFN=0,ACHSMR=N,ACHSMDFN=$O(^AUPNMCD("B",DFN,ACHSMDFN))
 G:ACHSMDFN="" RRE
 D DINACK("^AUPNMCD")
 G RRE:ACHSBZD("OK")="N"
 ;
 S ACHSINS=^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("^AUPNMRRE")
 G END:ACHSBZD("OK")="N"
 ;
 S ACHSINS=^AUPNRRE(ACHSMDFN,0),I(N,5)=$P(ACHSINS,U,3),I(N,1)=$P(ACHSINS,U,5)
 D SET("^AUPNRRE")
END ;
 KILL ACHSMDFN,DA,ACHSGL,ACHSINS,ACHSINS1,ACHSMR,ACHSBZD
 Q
 ;
SET(ACHSGL) ;
 S I(N,2)=$P(^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
 Q
 ;
DINACK(ACHSINSZ) ;
 ;-- Check for eligibility at Date Of Service.  Else, no print.
 ;-- ACHSINSZ contains the name of the insurance global.
 ;
 S ACHSBZD("OK")="N"
 Q:'$D(C(5))
 S X=C(5),%DT=""
 D ^%DT
 S ACHSBZD("DT")=Y,ACHSBZD("I")=0
 F  S ACHSBZD("I")=$O(@ACHSINSZ@(ACHSMDFN,11,ACHSBZD("I"))) Q:ACHSBZD("I")=""  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 eligibility 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
 ;