AZP3RP ;PRINT HCFA 1500 FORMS [ 01/24/91 3:55 PM ]
;FCJ PAO 10/22/90
VAR S RX="N" D ^AZP3UTL G:RX="" EXIT
B ;SET PRINT VARIABLES
S DOCNO=($E(BDOC,5,8)-1)+10000,DOCNO=$E(DOCNO,2,5),BDOC=$E(BDOC,1,4)_DOCNO
F S BDOC=$O(^AZPPI(1,"B",BDOC)) S BTSTDOC=$E(BDOC,1,2)_$E(BDOC,5,8) G:(BTSTDOC>ETSTDOC)!(BDOC="") EXIT S ND=0 D
.F S ND=$O(^AZPPI(1,"B",BDOC,ND)) Q:ND="" S DATA=^AZPPI(1,ND,0),DATA1=$G(^(1)),DUZ(2)=$P(DATA,U,9),DFN=$P(DATA,U,2) D B1
;G:($E(BDOC,1,2)>EFYDOC)!($E(BDOC,5,8)>EDOC)!(BDOC="") EXIT S ND=0 D
B1 ;PATIENT INSURANCE DATA
S LEND=1 S:$P(DATA1,U,7)'="" LEND=2 F L=1:1:2 F L1=1:1:10 S INS(L,L1)=""
F L=1:1:LEND S INSP(L)=$P(DATA1,U,L+5) D
.I $D(^AUTNINS(INSP(L))) S INS(L)=^AUTNINS(INSP(L),0) F L1=1:1:6 S INS(L,L1)=$P(INS(L),U,L1)
.S PT=0,PT=$O(^AUPNPRVT(DFN,11,"B",INSP(L),PT)),INS(L,9)=$P(^AUPNPRVT(DFN,11,PT,0),U,2),INS(L,7)=$P(^(0),U,4),INS(L,8)=$P(^(0),U,5)
.I INS(L,9)["/" S INS(L,10)=$P(INS(L,9),"/",2),INS(L,9)=$P(INS(L,9),"/")
.S RLS="" I INS(L,8)'="" S RLS=$P(^AUTTRLSH(INS(L,8),0),U) S INS(L,8)=$S(RLS="SELF":0,RLS="HUSBAND":3,RLS="WIFE":3,RLS="SPOUSE":3,RLS="DAUGHTER":6,RLS="SON":6,1:9)
F L=1:1:2 I INS(L,4)'="" S INS(L,4)=$P(^DIC(5,INS(L,4),0),U) S INS(L,4)=$E(INS(L,4),1,2)
B2 ;PATIENT DEMOGRAPHIC DATA
S DATA2=^DPT(DFN,0),NM=$P(DATA2,U,1),SX=$P(DATA2,U,2),SSN=$P(DATA2,U,9),SEX=$P(DATA2,U,2),DOB=$P(DATA2,U,3),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9),HRN=$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
S DATA2=^DPT(DFN,.11),STR=$P(DATA2,U,1),CTY=$P(DATA2,U,4),ZIP=$P(DATA2,U,6),ST=$P(DATA2,U,5),ST=$P(^DIC(5,ST,0),U)
S PHN="" I $D(^DPT(DFN,.13)) S PHN=$P(^(.13),U) S:$L(PHN)=10 PHN=$E(PHN,1,3)_"-"_$E(PHN,4,6)_"-"_$E(PHN,7,10) S:$L(PHN)=7 PHN=$E(PHN,1,3)_"-"_$E(PHN,4,7)
S SX=$S(SX="F":4,SX="M":0)
B3 ;CLAIM DATA
S PFAC=0,PFAC=$O(^AZPPI(0,"B",DUZ(2),PFAC)),DATAF=^AZPPI(0,PFAC,0),DATAF1=^(1),ARID=$P(DATAF1,U,3),FACID=$P(DATAF1,U,4) F L=1:1:5 S FAC(L)=$P(DATAF,U,L)
S FAC(1)=$P(^DIC(4,FAC(1),0),U),FAC(3)=$P(^AUTTCOM(FAC(3),0),U),FAC(4)=$P(^DIC(5,FAC(4),0),U) F L=3:1:7 S Y=$P(DATA,U,L) X ^DD("DD") S DT(L)=Y
S PHY=$P(DATA1,U),PHY=$P(^DIC(16,PHY,0),U)
S EMG=$P(DATA1,U,2),LAB=$P(DATA1,U,3),LABC=$P(DATA1,U,4),AUTH=$P(DATA1,U,5),RXCST=$P(DATA1,U,9)
C ;PRINTING
U IO W @IOF F L=1:1:3 W !?40,INS(1,L)
W " ",INS(1,4)," ",INS(1,5)
W !!!!!!!?3,NM,?34,$E(DOB,4,5),?40,$E(DOB,6,7),?46,$E(DOB,2,3),?52,INS(1,7)
W !!?3,STR,?40+SX,"X",?52,INS(1,9),!?3,CTY,?22,$E(ST,1,2),?25,ZIP
;CHECK ON POLICY FOR GROUP AND POLICY NUM FOR 2ND INS.
W !!?52,INS(1,10),!?10,PHN W:RLS'="" ?34+RLS,"X"
W !!!?3,INS(2,7),?52,"SAME AS BLOCK 4" F L=1:1:3 W !?3,INS(2,L)
W " ",INS(2,4)," ",INS(2,5),!?3,INS(2,6),!?3,INS(2,9)," ",INS(2,10)
W !?3,"Patient signature on file",?52,"Patient signature on file",!!!!?3,DT(3),?34,DT(5),?52,DT(4) W:EMG="Y" ?74,"X"
S TB=55 S:LAB="N" TB=TB+2 W !!,?20,DT(6),?34,DT(7),!!?3,PHY,!!?3,FAC(1),?TB,"X",?65,$J(LABC,10,2),!
S ICD=0 F S ICD=$O(^AZPPI(1,ND,2,ICD)) Q:ICD'?1N.N S PICD=$P(^(ICD,0),U) W !?3,$P(^ICD9(PICD,0),U)," ",$P(^(0),U,3)
S L=40-$Y F L1=1:1:L W !
W ?65,AUTH,!!!
S (TOTCPT,TOT,PDOS)=0 F S PDOS=$O(^AZPPI(1,ND,4,PDOS)) Q:PDOS'?1N.N S PCPT=0,Y=^(PDOS,0) X ^DD("DD") S DOS=Y D
.F S PCPT=$O(^AZPPI(1,ND,4,PDOS,1,PCPT)) Q:PCPT'?1N.N D
..S DATA3=^(PCPT,0),DATA4=$P(DATA3,U),DATA4=^AZPPI(2,DATA4,0) I $P(DATA4,U)="00000" S $P(DATA4,U,3)=RXCST
..S UNTS=$P(DATA3,U,4),TOTCPT=UNTS*($P(DATA4,U,3))
..W !?3,DOS,?15,$P(^AZPPI(6,$P(DATA3,U,2),0),U,2),?20,$P(DATA4,U),?28,$E($P(DATA4,U,2),1,21),?50,$P(DATA3,U,3),?53,$J(TOTCPT,10,2),?65,UNTS,?68,$P(^AZPPI(5,$P(DATA3,U,5),0),U,2) S TOT=TOTCPT+TOT
S L=56-$Y F L1=1:1:L W !
W ?53,$J(TOT,10,2),?67,"0.00",?68,$J(TOT,8,2),!!?52,"Portland Area IHS",!?52,FAC(1)
W !?5,DATE,?52,FAC(2),!?52,FAC(3)," ",$E(FAC(4),1,2)," ",FAC(5),!?3,BDOC,?35,ARID,?52,FACID,! Q
EXIT D KLL^AZP3UTL Q
AZP3RP ;PRINT HCFA 1500 FORMS [ 01/24/91 3:55 PM ]
+1 ;FCJ PAO 10/22/90
VAR SET RX="N"
DO ^AZP3UTL
IF RX=""
GOTO EXIT
B ;SET PRINT VARIABLES
+1 SET DOCNO=($EXTRACT(BDOC,5,8)-1)+10000
SET DOCNO=$EXTRACT(DOCNO,2,5)
SET BDOC=$EXTRACT(BDOC,1,4)_DOCNO
+2 FOR
SET BDOC=$ORDER(^AZPPI(1,"B",BDOC))
SET BTSTDOC=$EXTRACT(BDOC,1,2)_$EXTRACT(BDOC,5,8)
IF (BTSTDOC>ETSTDOC)!(BDOC="")
GOTO EXIT
SET ND=0
Begin DoDot:1
+3 FOR
SET ND=$ORDER(^AZPPI(1,"B",BDOC,ND))
IF ND=""
QUIT
SET DATA=^AZPPI(1,ND,0)
SET DATA1=$GET(^(1))
SET DUZ(2)=$PIECE(DATA,U,9)
SET DFN=$PIECE(DATA,U,2)
DO B1
End DoDot:1
+4 ;G:($E(BDOC,1,2)>EFYDOC)!($E(BDOC,5,8)>EDOC)!(BDOC="") EXIT S ND=0 D
B1 ;PATIENT INSURANCE DATA
+1 SET LEND=1
IF $PIECE(DATA1,U,7)'=""
SET LEND=2
FOR L=1:1:2
FOR L1=1:1:10
SET INS(L,L1)=""
+2 FOR L=1:1:LEND
SET INSP(L)=$PIECE(DATA1,U,L+5)
Begin DoDot:1
+3 IF $DATA(^AUTNINS(INSP(L)))
SET INS(L)=^AUTNINS(INSP(L),0)
FOR L1=1:1:6
SET INS(L,L1)=$PIECE(INS(L),U,L1)
+4 SET PT=0
SET PT=$ORDER(^AUPNPRVT(DFN,11,"B",INSP(L),PT))
SET INS(L,9)=$PIECE(^AUPNPRVT(DFN,11,PT,0),U,2)
SET INS(L,7)=$PIECE(^(0),U,4)
SET INS(L,8)=$PIECE(^(0),U,5)
+5 IF INS(L,9)["/"
SET INS(L,10)=$PIECE(INS(L,9),"/",2)
SET INS(L,9)=$PIECE(INS(L,9),"/")
+6 SET RLS=""
IF INS(L,8)'=""
SET RLS=$PIECE(^AUTTRLSH(INS(L,8),0),U)
SET INS(L,8)=$SELECT(RLS="SELF":0,RLS="HUSBAND":3,RLS="WIFE":3,RLS="SPOUSE":3,RLS="DAUGHTER":6,RLS="SON":6,1:9)
End DoDot:1
+7 FOR L=1:1:2
IF INS(L,4)'=""
SET INS(L,4)=$PIECE(^DIC(5,INS(L,4),0),U)
SET INS(L,4)=$EXTRACT(INS(L,4),1,2)
B2 ;PATIENT DEMOGRAPHIC DATA
+1 SET DATA2=^DPT(DFN,0)
SET NM=$PIECE(DATA2,U,1)
SET SX=$PIECE(DATA2,U,2)
SET SSN=$PIECE(DATA2,U,9)
SET SEX=$PIECE(DATA2,U,2)
SET DOB=$PIECE(DATA2,U,3)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
SET HRN=$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
+2 SET DATA2=^DPT(DFN,.11)
SET STR=$PIECE(DATA2,U,1)
SET CTY=$PIECE(DATA2,U,4)
SET ZIP=$PIECE(DATA2,U,6)
SET ST=$PIECE(DATA2,U,5)
SET ST=$PIECE(^DIC(5,ST,0),U)
+3 SET PHN=""
IF $DATA(^DPT(DFN,.13))
SET PHN=$PIECE(^(.13),U)
IF $LENGTH(PHN)=10
SET PHN=$EXTRACT(PHN,1,3)_"-"_$EXTRACT(PHN,4,6)_"-"_$EXTRACT(PHN,7,10)
IF $LENGTH(PHN)=7
SET PHN=$EXTRACT(PHN,1,3)_"-"_$EXTRACT(PHN,4,7)
+4 SET SX=$SELECT(SX="F":4,SX="M":0)
B3 ;CLAIM DATA
+1 SET PFAC=0
SET PFAC=$ORDER(^AZPPI(0,"B",DUZ(2),PFAC))
SET DATAF=^AZPPI(0,PFAC,0)
SET DATAF1=^(1)
SET ARID=$PIECE(DATAF1,U,3)
SET FACID=$PIECE(DATAF1,U,4)
FOR L=1:1:5
SET FAC(L)=$PIECE(DATAF,U,L)
+2 SET FAC(1)=$PIECE(^DIC(4,FAC(1),0),U)
SET FAC(3)=$PIECE(^AUTTCOM(FAC(3),0),U)
SET FAC(4)=$PIECE(^DIC(5,FAC(4),0),U)
FOR L=3:1:7
SET Y=$PIECE(DATA,U,L)
XECUTE ^DD("DD")
SET DT(L)=Y
+3 SET PHY=$PIECE(DATA1,U)
SET PHY=$PIECE(^DIC(16,PHY,0),U)
+4 SET EMG=$PIECE(DATA1,U,2)
SET LAB=$PIECE(DATA1,U,3)
SET LABC=$PIECE(DATA1,U,4)
SET AUTH=$PIECE(DATA1,U,5)
SET RXCST=$PIECE(DATA1,U,9)
C ;PRINTING
+1 USE IO
WRITE @IOF
FOR L=1:1:3
WRITE !?40,INS(1,L)
+2 WRITE " ",INS(1,4)," ",INS(1,5)
+3 WRITE !!!!!!!?3,NM,?34,$EXTRACT(DOB,4,5),?40,$EXTRACT(DOB,6,7),?46,$EXTRACT(DOB,2,3),?52,INS(1,7)
+4 WRITE !!?3,STR,?40+SX,"X",?52,INS(1,9),!?3,CTY,?22,$EXTRACT(ST,1,2),?25,ZIP
+5 ;CHECK ON POLICY FOR GROUP AND POLICY NUM FOR 2ND INS.
+6 WRITE !!?52,INS(1,10),!?10,PHN
IF RLS'=""
WRITE ?34+RLS,"X"
+7 WRITE !!!?3,INS(2,7),?52,"SAME AS BLOCK 4"
FOR L=1:1:3
WRITE !?3,INS(2,L)
+8 WRITE " ",INS(2,4)," ",INS(2,5),!?3,INS(2,6),!?3,INS(2,9)," ",INS(2,10)
+9 WRITE !?3,"Patient signature on file",?52,"Patient signature on file",!!!!?3,DT(3),?34,DT(5),?52,DT(4)
IF EMG="Y"
WRITE ?74,"X"
+10 SET TB=55
IF LAB="N"
SET TB=TB+2
WRITE !!,?20,DT(6),?34,DT(7),!!?3,PHY,!!?3,FAC(1),?TB,"X",?65,$JUSTIFY(LABC,10,2),!
+11 SET ICD=0
FOR
SET ICD=$ORDER(^AZPPI(1,ND,2,ICD))
IF ICD'?1N.N
QUIT
SET PICD=$PIECE(^(ICD,0),U)
WRITE !?3,$PIECE(^ICD9(PICD,0),U)," ",$PIECE(^(0),U,3)
+12 SET L=40-$Y
FOR L1=1:1:L
WRITE !
+13 WRITE ?65,AUTH,!!!
+14 SET (TOTCPT,TOT,PDOS)=0
FOR
SET PDOS=$ORDER(^AZPPI(1,ND,4,PDOS))
IF PDOS'?1N.N
QUIT
SET PCPT=0
SET Y=^(PDOS,0)
XECUTE ^DD("DD")
SET DOS=Y
Begin DoDot:1
+15 FOR
SET PCPT=$ORDER(^AZPPI(1,ND,4,PDOS,1,PCPT))
IF PCPT'?1N.N
QUIT
Begin DoDot:2
+16 SET DATA3=^(PCPT,0)
SET DATA4=$PIECE(DATA3,U)
SET DATA4=^AZPPI(2,DATA4,0)
IF $PIECE(DATA4,U)="00000"
SET $PIECE(DATA4,U,3)=RXCST
+17 SET UNTS=$PIECE(DATA3,U,4)
SET TOTCPT=UNTS*($PIECE(DATA4,U,3))
+18 WRITE !?3,DOS,?15,$PIECE(^AZPPI(6,$PIECE(DATA3,U,2),0),U,2),?20,$PIECE(DATA4,U),?28,$EXTRACT($PIECE(DATA4,U,2),1,21),?50,$PIECE(DATA3,U,3),?53,$JUSTIFY(TOTCPT,10,2),?65,UNTS,?68,$PIECE(^AZPPI(5,$PIECE(DATA3,U,5),0),U,2)
SET TOT=TOTCPT+TOT
End DoDot:2
End DoDot:1
+19 SET L=56-$Y
FOR L1=1:1:L
WRITE !
+20 WRITE ?53,$JUSTIFY(TOT,10,2),?67,"0.00",?68,$JUSTIFY(TOT,8,2),!!?52,"Portland Area IHS",!?52,FAC(1)
+21 WRITE !?5,DATE,?52,FAC(2),!?52,FAC(3)," ",$EXTRACT(FAC(4),1,2)," ",FAC(5),!?3,BDOC,?35,ARID,?52,FACID,!
QUIT
EXIT DO KLL^AZP3UTL
QUIT
