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

ABMDF4A.m

Go to the documentation of this file. 
  1. ABMDF4A ; IHS/ASDST/DMJ - ADA Dental Export -part 2 ;   
  1.  ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
  1.  ;Original;TMD;
  1.  ;
  1.  ;  IHS/DSD/DMJ - 7/20/98 - Patch 2 - NOIS XFA-0698-200102
  1.  ;                Meds showing up on split bill for ADA  & HCFA.
  1.  ;                Modified to show meds on HCFA only.
  1.  ;                Also add code so claim generator will not bomb
  1.  ;                if auto approve is turned on and Y2K fix to
  1.  ;                print 4 digit year in 3 birthdate fields.
  1.  ; IHS/ASDS/DMJ - 04/18/00 - V2.4 Patch 1 - NOIS HQW-0500-100040
  1.  ;     Modified location code to check for satellite first.  If no
  1.  ;     satellite use parent.
  1.  ;
  1.  ; IHS/SD/SDR - v2.5 p8 - IM12859
  1.  ;    Modified code to print Dentist License Number
  1.  ;
  1. ENT ;EP for getting data
  1.  S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABMP("INS")=$P(^(0),U,8)
  1.  S ABMP("PDFN")=$P(ABMP("B0"),U,5),ABMP("LDFN")=$P(ABMP("B0"),U,3)
  1.  S ABMP("VTYP")=$P(ABMP("B0"),U,7),ABMP("BTYP")=$P(ABMP("B0"),U,2)
  1.  Q:'ABMP("PDFN")!'ABMP("LDFN")!'ABMP("INS")
  1.  S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
  1.  ;
  1. BADDR S ABM("J")=ABMP("BDFN"),ABM("I")=$P(^AUTNINS(ABMP("INS"),0),U)_"-"_ABMP("INS")
  1.  S ABM("INS",ABM("I"),ABM("J"))=""
  1.  I $P($G(^AUTNINS(ABMP("INS"),2)),U)="N" D
  1.  .S ABM("INS",ABM("I"),ABM("J"))=ABMP("PDFN")
  1.  S ABM("IDFN")=ABMP("INS") D BADDR^ABMDLBL1 G PAT:'$D(ABM("ADD"))
  1.  S ABMF(1)=U_$P(ABM("ADD"),U,1),ABMF(2)="X"_U_$P(ABM("ADD"),U,2),ABMF(3)=$P(ABM("ADD"),U,3)
  1.  ;
  1. PAT S ABM("P0")=^DPT(ABMP("PDFN"),0)
  1.  S ABMF(6)=$P(ABM("P0"),U)_U_U_U_U_$S($P(ABM("P0"),U,2)="M":"X"_U,1:U_"X")
  1.  S ABMF(6)=ABMF(6)_"^"_$E($P(ABM("P0"),U,3),4,5)_U_$E($P(ABM("P0"),U,3),6,7)_U_($E($P(ABM("P0"),U,3),1,3)+1700)
  1.  K ABM("P0")
  1.  S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
  1.  D PAT^ABMDE1X,REMPL^ABMDE1X1,LOC^ABMDE1X1 K ABME
  1. LOC S $P(ABMF(23),U)=$P($P(ABMV("X1"),U),";",2)
  1.  S $P(ABMF(25),U)=$P(ABMV("X1"),U,3),$P(ABMF(27),U)=$P(ABMV("X1"),U,4)
  1.  S $P(ABMF(29),U)=$P(ABMV("X1"),U,6),$P(ABMF(29),U,3)=$P(ABMV("X1"),U,5)
  1.  ;
  1. INSNUM ;
  1.  S ABM("INUM")=$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,$P(ABMP("B0"),U,7),0)),U,8)
  1.  S:ABM("INUM")="" ABM("INUM")=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
  1.  I ABM("INUM")="" D
  1.  .S ABMPRV=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0))
  1.  .S:ABMPRV ABMPRV=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,ABMPRV,0)),U)
  1.  .S:ABMPRV ABM("INUM")=$P($G(^VA(200,ABMPRV,9999999.18,ABMP("INS"),0)),U,2)
  1.  S $P(ABMF(29),U,2)=ABM("INUM")
  1.  ;
  1. PRV S ABM("X")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),41,"C","A",0)) I ABM("X") D
  1.  .D SELBILL^ABMDE4X
  1.  .S ABMF(57)=$P(ABM("A"),U)_U_ABM("PNUM")_U_DT
  1. POL ;POLICY INFORMATION
  1.  N I S I=0 F  S I=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I)) Q:'I  D
  1.  .I $P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,I,0),"^",3)="I" S ABM("XIEN")=I
  1.  S Y=ABMP("INS"),ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_"," D SEL^ABMDE2X
  1.  S $P(ABMF(8),U)=$P($P(ABMV("X2"),U),";",2)
  1.  S $P(ABMF(9),U)=$P(ABMV("X2"),U,3)
  1.  S $P(ABMF(10),U)=$P(ABMV("X2"),U,4)
  1.  S $P(ABMF(10),U,2)=$P(ABMV("X1"),U,4)
  1.  S $P(ABMF(10),U,3)=$E($P(ABMV("X2"),U,7),4,5)
  1.  S $P(ABMF(10),U,4)=$E($P(ABMV("X2"),U,7),6,7)
  1.  S $P(ABMF(10),U,5)=($E($P(ABMV("X2"),U,7),1,3)+1700)
  1. EMPL S $P(ABMF(8),U,2)=$P(ABMV("X3"),U),$P(ABMF(9),U,3)=$P(ABMV("X3"),U,2),$P(ABMF(10),U,6)=$P(ABMV("X3"),U,3)
  1.  S $P(ABMF(9),U,4)=$P(ABMV("X3"),U,6),$P(ABMF(10),U,7)=$P(ABMV("X3"),U,7)
  1. REL G INS:'$P(ABMV("X2"),U,2)
  1.  S ABM=+$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2)
  1.  I ABM,ABM<8,ABM'=2 S $P(ABMF(5),U,$S(ABM=1:1,1:2))="X"
  1.  E  S $P(ABMF(6),U,$S(ABM=2:2,1:3))="X"
  1. INS S ABM("I")=0 F  S ABM("I")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("I"))) Q:'ABM("I")  D
  1.  .S ABM("XIEN")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("I"),0))
  1.  .S ABM("INSCO")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),U)
  1.  .I ABM("INSCO")'=ABMP("INS") D  S ABM("I")=99
  1.  ..I "U"[$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,3) Q
  1.  ..S Y=ABM("INSCO"),ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_"," D SEL^ABMDE2X
  1.  ..S $P(ABMF(12),U,3)=$P(^AUTNINS(ABM("INSCO"),0),U),$P(ABMF(13),U)=$P(^(0),U,2),$P(ABMF(14),U,3)=$$CSZ^ABMDUTL($P(^(0),U,3,5))
  1.  ..S $P(ABMF(13),U,2)=$P(ABMV("X3"),U,6),$P(ABMF(14),U,4)=$P(ABMV("X3"),U,7)
  1.  ..S $P(ABMF(12),U,5)=$P(ABMV("X3"),U),$P(ABMF(13),U,3)=$P(ABMV("X3"),U,2),$P(ABMF(14),U,5)=$P(ABMV("X3"),U,3)
  1.  ..S $P(ABMF(17),U)=$P($P(ABMV("X2"),U),";",2)
  1.  ..S $P(ABMF(17),U,2)=$P(ABMV("X1"),U,4)
  1.  ..S $P(ABMF(17),U,3)=$E($P(ABMV("X2"),U,7),4,5)
  1.  ..S $P(ABMF(17),U,4)=$E($P(ABMV("X2"),U,7),6,7)
  1.  ..S $P(ABMF(17),U,5)=($E($P(ABMV("X2"),U,7),1,3)+1700)
  1.  ..I $P(ABMV("X2"),U,2) D
  1.  ...S ABM=+$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2)
  1.  ...I ABM,ABM<8,ABM'=2 S $P(ABMF(16),U,$S(ABM=1:2,1:3))="X"
  1.  ...E  S $P(ABMF(17),U,$S(ABM=2:6,1:7))="X"
  1.  ..I $P($G(^AUTNINS(ABM("INSCO"),2)),U,5)="O" S $P(ABMF(12),U)="X"
  1.  ..E  S $P(ABMF(14),U)="X"
  1.  S:$P($G(ABMF(12)),U)="" $P(ABMF(12),U,2)="X"
  1.  S:$P($G(ABMF(14)),U)="" $P(ABMF(14),U,2)="X"
  1.  ;
  1. BNODES I $D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0)) S ABM("B4")=$G(^(4)),ABM("B7")=$G(^(7)),ABM("B8")=$G(^(8)),ABM("B9")=$G(^(9))
  1.  I $P(ABM("B9"),U)]"" S $P(ABMF(23),U,3)="X"
  1.  E  S $P(ABMF(23),U,2)="X"
  1.  ;
  1. ACCD S $P(ABMF(25),U,$S('$P(ABM("B8"),U,3):2,"12"[$P(ABM("B8"),U,3):3,1:2))="X"
  1.  S $P(ABMF(27),U,$S("12"[$P(ABM("B8"),U,3):2,1:3))="X"
  1. FSYM S $P(ABMF(31),U)=$P(ABM("B8"),U,6)
  1.  I $P(ABM("B7"),U,4)="Y" S ABMF(20)="SIGNATURE ON FILE"_U_DT
  1.  I $P(ABM("B7"),U,5)="Y" S $P(ABMF(20),U,3)="SIGNATURE ON FILE",$P(ABMF(20),U,4)=DT
  1.  S $P(ABMF(31),U,2)="X"
  1. XRAY S $P(ABMF(31),U,$S($P(ABM("B4"),U,3):7,1:6))="X"
  1.  S $P(ABMF(31),U,8)=$P(ABM("B4"),U,3)
  1. ORTHO S $P(ABMF(31),U,$S($P(ABM("B4"),U,4):10,1:9))="X"
  1.  I $P(ABM("B4"),U,4) S $P(ABMF(31),U,11)=$P(ABM("B4"),U,5)
  1. PROTH S $P(ABMF(29),U,$S($P(ABM("B4"),U,6):5,1:4))="X"
  1.  I $P(ABM("B4"),U,6) S $P(ABMF(29),U,6)=$P(ABM("B4"),U,7)
  1.  S $P(ABMF(54),U)="Bill Number: "_$P(ABMP("B0"),U)_$S($P($G(^ABMDPARM(DUZ(2),1,1,2)),U,4)]"":"-"_$P(^(2),U,4),1:"") I $P($G(^(3)),U,3),$P($G(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2) S $P(ABMF(54),U)=$P(ABMF(54),U)_" "_$P(^(0),U,2)
  1.  ;
  1. XIT K ABM,ABMV
  1.  Q