ACHSRP3D ; IHS/ITSC/PMF - PRINT CHS (57 - DENTAL) FORMS ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,27**;JUN 11,2001;Build 43
;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
;ACHS*3.1*27 12/12/17 IHS.OIT.FCJ NEW MBI AND TEST FOR COV TYPE AND DATES
;
S ACHSSF="",LS=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6),ACHSLCA=$P($G(^(0)),U,7),ACHSTYPE=$P($G(^(0)),U,2)
S:LS ACHSSF="S"_LS
S:ACHSLCA ACHSSF="C"_ACHSLCA
I ACHSTYPE="S" S E(11)=E(7),X=$P($G(^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):$G(F(7))_" "_$G(F(9))_" SCC: "_$G(F(8)),1:"J123456 99.9Z")
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($G(^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 ;
;ACHS*3.1*27 REWROTE SECTION FOR MBI
G NO3:'$D(A(9)),MCD:'$D(^AUPNMCR(DFN,0))
;NEW MBI AND CHECK FOR "D" COVERAGE AND ELIG DATES
S ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
I +ACHSMBI<1 S ACHSMBI=$P(^AUPNMCR(DFN,0),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^(0),U,4),0)) S ACHSMBI=ACHSMBI_$P(^(0),U)
;GO THRU 'MEDICARE ELIGIBLE' FILE BUT ONLY PRINTING 1
S I=0,JJ=0
F S I=$O(^AUPNMCR(DFN,11,I)) Q:+I=0 D Q:JJ=1
.Q:ACHSEDOS<$P($G(^AUPNMCR(DFN,11,I,0)),U)
.I $P($G(^AUPNMCR(DFN,11,I,0)),U,2)'="" Q:ACHSEDOS>$P($G(^AUPNMCR(DFN,11,I,0)),U,2)
.S JJ=1
.W !?ACHSTAB+15,"MCR:"
.I $P($G(^AUPNMCR(DFN,11,I,0)),U,3)?1"D" W $P($G(^AUPNMCR(DFN,11,I,0)),U,6) ;'COVERAGE TYPE'
.E W ACHSMBI
.W ":",$P($G(^AUPNMCR(DFN,11,I,0)),U,3) ;'COVERAGE TYPE'
.W ":",$E($P($G(^AUPNMCR(DFN,11,I,0)),U),2,7) ;'ELIG. DATE'
.W ":",$E($P($G(^AUPNMCR(DFN,11,I,0)),U,2),2,7) ;'ELIG. END DATE'
;
;G NO3:'$D(A(9)),MCD:'$D(^AUPNMCR(DFN,0)),MCD:'$P(^(0),U,3)
;W !?ACHSTAB+15,"MCR:",$P($G(^AUPNMCR(DFN,0)),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0)) W $P(^(0),U)
;*********LOOP THRU MEDCARE ELIGIBLE FILE
;S JJ=0
;F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I S:I>JJ JJ=I
;I JJ W ":",$P(^AUPNMCR(DFN,11,JJ,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
MCD ;
;ACHS*3.1*27 MULT CHANGES TO TEST FOR ELIG DATE
G RRE:'$D(^AUPNMCD("B",DFN))
F R=0:0 S R=$O(^AUPNMCD("B",DFN,R)) Q:'R S X=R
S JJ=0
F I=0:0 S I=$O(^AUPNMCD(X,11,I)) Q:+I'=I D Q:JJ=1
.Q:ACHSEDOS<$P(^AUPNMCD(X,11,I,0),U)
.I $P(^AUPNMCD(X,11,I,0),U,2)="" S JJ=1 Q
.I ACHSEDOS>$P(^AUPNMCD(X,11,I,0),U,2) Q
.S JJ=1
I JJ D
.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)
.W ":",$P(^AUPNMCD(X,11,I,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
RRE ;
;ACHS*3.1*27 REWROTE SECTION FOR MBI
G PVT:'$D(^AUPNRRE(DFN,0))
S JJ=0
F I=0:0 S I=$O(^AUPNRRE(DFN,11,I)) Q:+I'=I D Q:JJ=1
.Q:ACHSEDOS<$P(^AUPNRRE(DFN,11,I,0),U)
.I $P(^AUPNRRE(DFN,11,I,0),U,2)="" S JJ=1 Q
.I ACHSEDOS>$P(^AUPNRRE(DFN,11,I,0),U,2) Q
.S JJ=1
G PVT:JJ=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 ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
I +ACHSMBI<1 D
.S ACHSMBI=""
.S:$P($G(^AUPNRRE(DFN,0)),U,3)'="" ACHSMBI=$P(^AUTTRRP($P(^AUPNRRE(DFN,0),U,3),0),U)
.S ACHSMBI=ACHSMBI_$P($G(^AUPNRRE(DFN,0)),U,4) ;PRNT PREFIX FOR OLD NUMBER
W ?$S($Y=45:ACHSTAB+15,$X'>ACHSTAB:ACHSTAB,1:$X+5),"RRR:",ACHSMBI
S JJ=0
F S JJ=$O(^AUPNRRE(DFN,11,JJ)) Q:JJ'?1N.N D
. W ":",$P(^AUPNRRE(DFN,11,JJ,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
.Q
W !
PVT ;*******LOOP THRU PRIVATE INSURANCE ELIGIBLE FILE
G NO3:'$D(^AUPNPRVT(DFN,11)),NO3:'$O(^(11,0))
W:$Y=44 !
S I=0
;ACHS*3.1*27 MULT CHANGES TO TEST FOR ELIG DATES
F S I=$O(^AUPNPRVT(DFN,11,I)) Q:I'?1N.N D
.S I2=^AUPNPRVT(DFN,11,I,0)
.Q:ACHSEDOS<$P(I2,U,6)
.I $P(I2,U,7)'="" Q:ACHSEDOS>($P(I2,U,7))
.W ?ACHSTAB+$S($Y=45:15,1:0),$E($P(^AUTNINS($P(I2,U),0),U),1,8),":"
.I I2,$D(^AUPN3PPH($P(I2,U,8),0)) D
..W $P(^AUPN3PPH($P(I2,U,8),0),U,4),":"
..I $P(^AUPN3PPH($P(I2,U,8),0),U,5) W $P(^AUTTPIC($P(^AUPN3PPH($P(I2,U,8),0),U,5),0),U)
.W ":",$E($P(I2,U,6),2,7),":",$E($P(I2,U,7),2,7)," " W:$X>50 !
;
NO3 ;
W:$Y=44 !?ACHSTAB+15,"THIRD PARTY RESOURCES: NONE"
END ;
W @IOF
K 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 _________________________.
ACHSRP3D ; IHS/ITSC/PMF - PRINT CHS (57 - DENTAL) FORMS ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,27**;JUN 11,2001;Build 43
+2 ;ACHS*3.1*13 11/22/06 IHS/OIT/FCJ PRT POLICY # & COV FR CORRECT FILES
+3 ;ACHS*3.1*27 12/12/17 IHS.OIT.FCJ NEW MBI AND TEST FOR COV TYPE AND DATES
+4 ;
+5 SET ACHSSF=""
SET LS=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,6)
SET ACHSLCA=$PIECE($GET(^(0)),U,7)
SET ACHSTYPE=$PIECE($GET(^(0)),U,2)
+6 IF LS
SET ACHSSF="S"_LS
+7 IF ACHSLCA
SET ACHSSF="C"_ACHSLCA
+8 IF ACHSTYPE="S"
SET E(11)=E(7)
SET X=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U)
SET E(7)=$EXTRACT(X,4,5)_"-"_$EXTRACT(X,6,7)_"-"_$EXTRACT(X,2,3)
+9 DO KILLNULS^ACHSRP3
TESTPRNT ;EP.
+1 FOR I=1:1:ACHSTOPM
WRITE !
FACHRN ;
+1 WRITE !
+2 IF $DATA(A(1))
WRITE ?ACHSTAB,$EXTRACT(A(1),1,28)
FROMTO ;
+1 IF $DATA(C(4))
WRITE ?ACHSTAB+38,C(4)
PONUM ;
+1 WRITE ?ACHSTAB+54,$SELECT($$PARM^ACHS(2,20)="Y":$SELECT(ACHSTYPV=1:323,ACHSTYPV=2:324,1:325),1:""),?ACHSTAB+62,"0",ACHSORDN,ACHSSF
NAME ;
+1 WRITE !
+2 IF $DATA(A(2))
WRITE ?ACHSTAB,A(2)
DCR ;
+1 IF $$PARM^ACHS(2,18)="Y"
WRITE ?ACHSTAB+67,"(",ACHSDCR,")"
PTADRS ;
+1 WRITE !
+2 IF $DATA(A(3))
WRITE ?ACHSTAB,A(3)
SIG ;
+1 WRITE ?ACHSTAB+37,ACHSSIG
DT ;
+1 WRITE ?ACHSTAB+64,E(7)
DOBSEX ;
+1 WRITE !?ACHSTAB
+2 IF $DATA(A(4))
WRITE A(4)
COMCODE ;
+1 IF $DATA(A(5))
WRITE " ",A(5)
ORDOFF ;
+1 WRITE !?ACHSTAB+37,$EXTRACT(B(1),1,25)
SUCODE ;
+1 WRITE ?ACHSTAB+64,B(4)
AGESEX ;
+1 WRITE !?ACHSTAB+2
+2 IF $DATA(A(4))
WRITE $EXTRACT(A(4),1,8),?ACHSTAB+26,$EXTRACT(A(4),11)
ORDADRS ;
+1 IF $DATA(B(3))
WRITE ?ACHSTAB+37,B(3)
DEST ;
+1 IF $DATA(D(5))
WRITE ?ACHSTAB+64,D(5)
SSV ;
+1 WRITE !
+2 IF $GET(DFN)
SET X=$$SSV^ACHSTX3(DFN)
IF "PVX"[X
WRITE ?ACHSTAB+11,X
SSN ;
+1 WRITE !?ACHSTAB+11
+2 IF $DATA(A(11))
WRITE A(11)
PROV ;
+1 WRITE ?ACHSTAB+37,$EXTRACT(D(1),1,23)
PTYPE ;
+1 IF $$PARM^ACHS(2,17)="Y"
IF $DATA(D(7))
WRITE $SELECT($X<60:" ",1:""),D(7)
EIN ;
+1 IF $DATA(D(4))
SET D(4)=$PIECE(D(4)," ",1)
WRITE ?ACHSTAB+62,D(4)
PADRS ;
+1 IF $DATA(D(2))
WRITE !?ACHSTAB+48,$EXTRACT(D(2),1,30)
+2 IF $DATA(D(3))
WRITE !?ACHSTAB+48,$EXTRACT(D(3),1,30)
CANOBJ ;
+1 WRITE !?10,$SELECT('$DATA(ACHSTPRT):$GET(F(7))_" "_$GET(F(9))_" SCC: "_$GET(F(8)),1:"J123456 99.9Z")
DESC ;
+1 WRITE !
+2 IF $DATA(A(7))
WRITE ?ACHSTAB,A(7)
CONTNO ;
+1 WRITE !
+2 IF $DATA(F(6))
WRITE ?19,F(6)
OBLGAMT ;
+1 WRITE ?ACHSTAB+38,E(9)
+2 IF $DATA(ACHSTPRT)
GOTO END
REFTYPE ;
+1 WRITE !!!!!!
+2 SET ACHSLREF=$EXTRACT($PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,0)),U,11)_$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,3)),U,10))
+3 IF $LENGTH(ACHSLREF)
FOR I=3:1:7
WRITE !?ACHSTAB+18,$PIECE($TEXT(@ACHSLREF),";",I)
+4 IF ACHSTYPE="C"!(ACHSTYPE="S")
WRITE !!!!!!!
DO CSUPLA^ACHSRP3
GOTO END
+5 FOR
IF $Y=44
QUIT
WRITE !
MCR ;
+1 ;ACHS*3.1*27 REWROTE SECTION FOR MBI
+2 IF '$DATA(A(9))
GOTO NO3
IF '$DATA(^AUPNMCR(DFN,0))
GOTO MCD
+3 ;NEW MBI AND CHECK FOR "D" COVERAGE AND ELIG DATES
+4 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+5 IF +ACHSMBI<1
SET ACHSMBI=$PIECE(^AUPNMCR(DFN,0),U,3)
IF $PIECE(^(0),U,4)
IF $DATA(^AUTTMCS($PIECE(^(0),U,4),0))
SET ACHSMBI=ACHSMBI_$PIECE(^(0),U)
+6 ;GO THRU 'MEDICARE ELIGIBLE' FILE BUT ONLY PRINTING 1
+7 SET I=0
SET JJ=0
+8 FOR
SET I=$ORDER(^AUPNMCR(DFN,11,I))
IF +I=0
QUIT
Begin DoDot:1
+9 IF ACHSEDOS<$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U)
QUIT
+10 IF $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2)'=""
IF ACHSEDOS>$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2)
QUIT
+11 SET JJ=1
+12 WRITE !?ACHSTAB+15,"MCR:"
+13 ;'COVERAGE TYPE'
IF $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)?1"D"
WRITE $PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,6)
+14 IF '$TEST
WRITE ACHSMBI
+15 ;'COVERAGE TYPE'
WRITE ":",$PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,3)
+16 ;'ELIG. DATE'
WRITE ":",$EXTRACT($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U),2,7)
+17 ;'ELIG. END DATE'
WRITE ":",$EXTRACT($PIECE($GET(^AUPNMCR(DFN,11,I,0)),U,2),2,7)
End DoDot:1
IF JJ=1
QUIT
+18 ;
+19 ;G NO3:'$D(A(9)),MCD:'$D(^AUPNMCR(DFN,0)),MCD:'$P(^(0),U,3)
+20 ;W !?ACHSTAB+15,"MCR:",$P($G(^AUPNMCR(DFN,0)),U,3) I $P(^(0),U,4),$D(^AUTTMCS($P(^AUPNMCR(DFN,0),U,4),0)) W $P(^(0),U)
+21 ;*********LOOP THRU MEDCARE ELIGIBLE FILE
+22 ;S JJ=0
+23 ;F I=0:0 S I=$O(^AUPNMCR(DFN,11,I)) Q:+I'=I S:I>JJ JJ=I
+24 ;I JJ W ":",$P(^AUPNMCR(DFN,11,JJ,0),U,3),":",$E($P(^(0),U),2,7),":",$E($P(^(0),U,2),2,7)
MCD ;
+1 ;ACHS*3.1*27 MULT CHANGES TO TEST FOR ELIG DATE
+2 IF '$DATA(^AUPNMCD("B",DFN))
GOTO RRE
+3 FOR R=0:0
SET R=$ORDER(^AUPNMCD("B",DFN,R))
IF 'R
QUIT
SET X=R
+4 SET JJ=0
+5 FOR I=0:0
SET I=$ORDER(^AUPNMCD(X,11,I))
IF +I'=I
QUIT
Begin DoDot:1
+6 IF ACHSEDOS<$PIECE(^AUPNMCD(X,11,I,0),U)
QUIT
+7 IF $PIECE(^AUPNMCD(X,11,I,0),U,2)=""
SET JJ=1
QUIT
+8 IF ACHSEDOS>$PIECE(^AUPNMCD(X,11,I,0),U,2)
QUIT
+9 SET JJ=1
End DoDot:1
IF JJ=1
QUIT
+10 IF JJ
Begin DoDot:1
+11 WRITE !?ACHSTAB+$SELECT($Y=45:15,1:0),"MCD:",$PIECE(^AUPNMCD(X,0),U,3)
IF $PIECE(^(0),U,4)
IF $DATA(^DIC(5,$PIECE(^(0),U,4),0))
WRITE $PIECE(^(0),U,2)
+12 WRITE ":",$PIECE(^AUPNMCD(X,11,I,0),U,3),":",$EXTRACT($PIECE(^(0),U),2,7),":",$EXTRACT($PIECE(^(0),U,2),2,7)
End DoDot:1
RRE ;
+1 ;ACHS*3.1*27 REWROTE SECTION FOR MBI
+2 IF '$DATA(^AUPNRRE(DFN,0))
GOTO PVT
+3 SET JJ=0
+4 FOR I=0:0
SET I=$ORDER(^AUPNRRE(DFN,11,I))
IF +I'=I
QUIT
Begin DoDot:1
+5 IF ACHSEDOS<$PIECE(^AUPNRRE(DFN,11,I,0),U)
QUIT
+6 IF $PIECE(^AUPNRRE(DFN,11,I,0),U,2)=""
SET JJ=1
QUIT
+7 IF ACHSEDOS>$PIECE(^AUPNRRE(DFN,11,I,0),U,2)
QUIT
+8 SET JJ=1
End DoDot:1
IF JJ=1
QUIT
+9 IF JJ=0
GOTO PVT
+10 IF $Y=44
WRITE !
+11 ;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)
+12 SET ACHSMBI=$$GETMBI^AUPNMBI(DFN,DT,0)
+13 IF +ACHSMBI<1
Begin DoDot:1
+14 SET ACHSMBI=""
+15 IF $PIECE($GET(^AUPNRRE(DFN,0)),U,3)'=""
SET ACHSMBI=$PIECE(^AUTTRRP($PIECE(^AUPNRRE(DFN,0),U,3),0),U)
+16 ;PRNT PREFIX FOR OLD NUMBER
SET ACHSMBI=ACHSMBI_$PIECE($GET(^AUPNRRE(DFN,0)),U,4)
End DoDot:1
+17 WRITE ?$SELECT($Y=45:ACHSTAB+15,$X'>ACHSTAB:ACHSTAB,1:$X+5),"RRR:",ACHSMBI
+18 SET JJ=0
+19 FOR
SET JJ=$ORDER(^AUPNRRE(DFN,11,JJ))
IF JJ'?1N.N
QUIT
Begin DoDot:1
+20 WRITE ":",$PIECE(^AUPNRRE(DFN,11,JJ,0),U,3),":",$EXTRACT($PIECE(^(0),U),2,7),":",$EXTRACT($PIECE(^(0),U,2),2,7)
+21 QUIT
End DoDot:1
+22 WRITE !
PVT ;*******LOOP THRU PRIVATE INSURANCE ELIGIBLE FILE
+1 IF '$DATA(^AUPNPRVT(DFN,11))
GOTO NO3
IF '$ORDER(^(11,0))
GOTO NO3
+2 IF $Y=44
WRITE !
+3 SET I=0
+4 ;ACHS*3.1*27 MULT CHANGES TO TEST FOR ELIG DATES
+5 FOR
SET I=$ORDER(^AUPNPRVT(DFN,11,I))
IF I'?1N.N
QUIT
Begin DoDot:1
+6 SET I2=^AUPNPRVT(DFN,11,I,0)
+7 IF ACHSEDOS<$PIECE(I2,U,6)
QUIT
+8 IF $PIECE(I2,U,7)'=""
IF ACHSEDOS>($PIECE(I2,U,7))
QUIT
+9 WRITE ?ACHSTAB+$SELECT($Y=45:15,1:0),$EXTRACT($PIECE(^AUTNINS($PIECE(I2,U),0),U),1,8),":"
+10 IF I2
IF $DATA(^AUPN3PPH($PIECE(I2,U,8),0))
Begin DoDot:2
+11 WRITE $PIECE(^AUPN3PPH($PIECE(I2,U,8),0),U,4),":"
+12 IF $PIECE(^AUPN3PPH($PIECE(I2,U,8),0),U,5)
WRITE $PIECE(^AUTTPIC($PIECE(^AUPN3PPH($PIECE(I2,U,8),0),U,5),0),U)
End DoDot:2
+13 WRITE ":",$EXTRACT($PIECE(I2,U,6),2,7),":",$EXTRACT($PIECE(I2,U,7),2,7)," "
IF $X>50
WRITE !
End DoDot:1
+14 ;
NO3 ;
+1 IF $Y=44
WRITE !?ACHSTAB+15,"THIRD PARTY RESOURCES: NONE"
END ;
+1 WRITE @IOF
+2 KILL ACHSLREF
+3 QUIT
+4 ;
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 _________________________.
