Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AZP3RP

AZP3RP.m

Go to the documentation of this file.
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