- ABMDF1 ; IHS/ASDST/DMJ - Set UB82 Print Array ;
- ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
- ;Original;TMD;
- ;
- K ABMP S U="^",ABMP("XMIT")=0,ABMP("EXP")=1,ABMY("TOT")="0^0^0"
- BDFN S ABMY("N")=0 F S ABMY("N")=$O(ABMY(ABMY("N"))) Q:'ABMY("N") D
- .S ABMP("BDFN")=0 F S ABMP("BDFN")=$O(ABMY(ABMY("N"),ABMP("BDFN"))) Q:'ABMP("BDFN") D
- ..Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
- ..D ENT,^ABMDF1X
- ..S $P(ABMY("TOT"),U)=$P(ABMY("TOT"),U)+1
- ..D:$D(ABMR)=10 UB82
- XMIT ..I ABMP("XMIT")=0 S ABM("XM")="" F S ABM("XM")=$O(^ABMDTXST(DUZ(2),"B",DT,ABM("XM"))) Q:'ABM("XM") D Q:ABMP("XMIT")
- ...Q:'$D(^ABMDTXST(DUZ(2),ABM("XM"),0)) Q:$P(^(0),U,2)'=ABMP("EXP")
- ...I $D(ABMY("TYP")),$P(^ABMDTXST(DUZ(2),ABM("XM"),0),U,3)=ABMY("TYP") S ABMP("XMIT")=ABM("XM")
- ...I $D(ABMY("INS")),$P(^ABMDTXST(DUZ(2),ABM("XM"),0),U,4)=ABMY("INS") S ABMP("XMIT")=ABM("XM")
- ..I '+ABMP("XMIT") S DIC="^ABMDTXST(DUZ(2),",DIC(0)="L",X=DT,DIC("DR")=".02////1;.07////1;.08////1;"_$S($D(ABMY("TYP")):".03////"_ABMY("TYP"),$D(ABMY("INS")):".04////"_$P(ABMY("INS"),U),1:".03////A")_";.05////"_DUZ
- ..I K DD,DO D FILE^DICN S ABMP("XMIT")=+Y
- ..S DIE="^ABMDBILL(DUZ(2),",DA=ABMP("BDFN"),DR=".04////B;.16////A;.17////"_ABMP("XMIT") D ^ABMDDIE Q:$D(ABM("DIE-FAIL"))
- ..K ^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"A",ABMP("BDFN"))
- ..S ABM=ABMP("BDFN"),ABM("L")=ABMP("XMIT") K ABMP S ABMP("XMIT")=ABM("L"),ABMP("BDFN")=ABM
- G XIT
- ;
- UB82 ;EP for printing export array
- S ABMR="" F ABMR("I")=17:1:39 S ABMR=$O(ABMR(ABMR)) Q:'ABMR D
- .S ABMF(ABMR("I"))=ABMR(ABMR)
- .K ABMR(ABMR)
- .Q
- I ABMR("I")=39,+ABMR D ^ABMDF1X G UB82
- F ABMR("I")=ABMR("I"):1:48 K ABMF(ABMR("I"))
- I ABMR("I")<39 S ABMF(ABMR("I")+1)=ABMR("TOT")
- E S ABMF(39)=ABMR("TOT")
- D ^ABMDF1X
- Q
- ;
- ENT ;EP for setting up export array
- K ABMF,ABM,ABMU,ABMR,ABMS
- S:'$D(ABMY("TOT")) ABMY("TOT")="0^0^0"
- S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABMP("INS")=$P(ABMP("B0"),U,8) Q:'ABMP("INS")
- S ABMP("PDFN")=$P(ABMP("B0"),U,5),ABMP("LDFN")=$P(ABMP("B0"),U,3),ABMP("VTYP")=$P(ABMP("B0"),U,7) Q:'ABMP("PDFN")!('+ABMP("LDFN"))
- S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
- S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
- D PAT^ABMDE1X,REMPL^ABMDE1X1,LOC^ABMDE1X1 K ABME
- ;
- LOC S ABMF(1)=$P($P(ABMV("X1"),U),";",2)
- I $P(ABMV("X1"),U,2)]"" S ABMF(2)=$P(ABMV("X1"),U,2),ABMF(3)=$P(ABMV("X1"),U,3),ABMF(4)=$P(ABMV("X1"),U,4)
- E S ABMF(2)=$P(ABMV("X1"),U,3),ABMF(3)=$P(ABMV("X1"),U,4),ABMF(4)=$P(ABMV("X1"),U,5)
- BNUM S $P(ABMF(2),U,3)=$P(ABMP("B0"),U,1)_$S($P($G(^ABMDPARM(DUZ(2),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(2),U,3)=$P(ABMF(2),U,3)_" "_$P(^(0),U,2)
- BTYPE S $P(ABMF(2),U,4)=$S($P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11):$P($G(^ABMDCODE($P(^(0),U,11),0)),U),1:$P(ABMP("B0"),U,2))
- INSNUM S ABM("INUM")=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
- S:ABM("INUM")="" ABM("INUM")=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
- S $P(ABMF(4),U,$S($P($G(^AUTNINS(ABMP("INS"),2)),U)="D":5,1:2))=ABM("INUM")
- TAX S $P(ABMF(4),U,3)=$P(ABMV("X1"),U,6)
- ;
- ; Line 6
- PNODES S ABM("P0")=^DPT(ABMP("PDFN"),0)
- SSN I $P(ABM("P0"),U,9)]"" S $P(ABMF(12),U,12)=$S($P(ABM("P0"),U,9)'["-":$E($P(ABM("P0"),U,9),1,3)_"-"_$E($P(ABM("P0"),U,9),4,5)_"-"_$E($P(ABM("P0"),U,9),6,9),1:$P(ABM("P0"),U,9))
- NAME S ABMF(6)=$P(ABM("P0"),U)
- ADDRESS S $P(ABMF(6),U,2)=$P(ABMV("X2"),U,3)_" "_$P(ABMV("X2"),U,4)
- ;
- ; Line 8
- DOB S ABMF(8)=$P(ABMV("X2"),U,6)
- SEX S $P(ABMF(8),U,2)=$P(ABMV("X2"),U,2)
- MS S $P(ABMF(8),U,3)=$P(ABMV("X2"),U,7)
- K ABM("P0")
- ;
- G ^ABMDF1A
- ;
- XIT K ABM,ABMV,ABMF
- Q
- ABMDF1 ; IHS/ASDST/DMJ - Set UB82 Print Array ;
- +1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
- +2 ;Original;TMD;
- +3 ;
- +4 KILL ABMP
- SET U="^"
- SET ABMP("XMIT")=0
- SET ABMP("EXP")=1
- SET ABMY("TOT")="0^0^0"
- BDFN SET ABMY("N")=0
- FOR
- SET ABMY("N")=$ORDER(ABMY(ABMY("N")))
- IF 'ABMY("N")
- QUIT
- Begin DoDot:1
- +1 SET ABMP("BDFN")=0
- FOR
- SET ABMP("BDFN")=$ORDER(ABMY(ABMY("N"),ABMP("BDFN")))
- IF 'ABMP("BDFN")
- QUIT
- Begin DoDot:2
- +2 IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),0))
- QUIT
- +3 DO ENT
- DO ^ABMDF1X
- +4 SET $PIECE(ABMY("TOT"),U)=$PIECE(ABMY("TOT"),U)+1
- +5 IF $DATA(ABMR)=10
- DO UB82
- XMIT IF ABMP("XMIT")=0
- SET ABM("XM")=""
- FOR
- SET ABM("XM")=$ORDER(^ABMDTXST(DUZ(2),"B",DT,ABM("XM")))
- IF 'ABM("XM")
- QUIT
- Begin DoDot:3
- +1 IF '$DATA(^ABMDTXST(DUZ(2),ABM("XM"),0))
- QUIT
- IF $PIECE(^(0),U,2)'=ABMP("EXP")
- QUIT
- +2 IF $DATA(ABMY("TYP"))
- IF $PIECE(^ABMDTXST(DUZ(2),ABM("XM"),0),U,3)=ABMY("TYP")
- SET ABMP("XMIT")=ABM("XM")
- +3 IF $DATA(ABMY("INS"))
- IF $PIECE(^ABMDTXST(DUZ(2),ABM("XM"),0),U,4)=ABMY("INS")
- SET ABMP("XMIT")=ABM("XM")
- End DoDot:3
- IF ABMP("XMIT")
- QUIT
- +4 IF '+ABMP("XMIT")
- SET DIC="^ABMDTXST(DUZ(2),"
- SET DIC(0)="L"
- SET X=DT
- SET DIC("DR")=".02////1;.07////1;.08////1;"_$SELECT($DATA(ABMY("TYP")):".03////"_ABMY("TYP"),$DATA(ABMY("INS")):".04////"_$PIECE(ABMY("INS"),U),1:".03////A")_";.05////"_DUZ
- +5 IF $TEST
- KILL DD,DO
- DO FILE^DICN
- SET ABMP("XMIT")=+Y
- +6 SET DIE="^ABMDBILL(DUZ(2),"
- SET DA=ABMP("BDFN")
- SET DR=".04////B;.16////A;.17////"_ABMP("XMIT")
- DO ^ABMDDIE
- IF $DATA(ABM("DIE-FAIL"))
- QUIT
- +7 KILL ^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),"A",ABMP("BDFN"))
- +8 SET ABM=ABMP("BDFN")
- SET ABM("L")=ABMP("XMIT")
- KILL ABMP
- SET ABMP("XMIT")=ABM("L")
- SET ABMP("BDFN")=ABM
- End DoDot:2
- End DoDot:1
- +9 GOTO XIT
- +10 ;
- UB82 ;EP for printing export array
- +1 SET ABMR=""
- FOR ABMR("I")=17:1:39
- SET ABMR=$ORDER(ABMR(ABMR))
- IF 'ABMR
- QUIT
- Begin DoDot:1
- +2 SET ABMF(ABMR("I"))=ABMR(ABMR)
- +3 KILL ABMR(ABMR)
- +4 QUIT
- End DoDot:1
- +5 IF ABMR("I")=39
- IF +ABMR
- DO ^ABMDF1X
- GOTO UB82
- +6 FOR ABMR("I")=ABMR("I"):1:48
- KILL ABMF(ABMR("I"))
- +7 IF ABMR("I")<39
- SET ABMF(ABMR("I")+1)=ABMR("TOT")
- +8 IF '$TEST
- SET ABMF(39)=ABMR("TOT")
- +9 DO ^ABMDF1X
- +10 QUIT
- +11 ;
- ENT ;EP for setting up export array
- +1 KILL ABMF,ABM,ABMU,ABMR,ABMS
- +2 IF '$DATA(ABMY("TOT"))
- SET ABMY("TOT")="0^0^0"
- +3 SET ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)
- SET ABMP("INS")=$PIECE(ABMP("B0"),U,8)
- IF 'ABMP("INS")
- QUIT
- +4 SET ABMP("PDFN")=$PIECE(ABMP("B0"),U,5)
- SET ABMP("LDFN")=$PIECE(ABMP("B0"),U,3)
- SET ABMP("VTYP")=$PIECE(ABMP("B0"),U,7)
- IF 'ABMP("PDFN")!('+ABMP("LDFN"))
- QUIT
- +5 SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
- +6 SET (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""
- +7 DO PAT^ABMDE1X
- DO REMPL^ABMDE1X1
- DO LOC^ABMDE1X1
- KILL ABME
- +8 ;
- LOC SET ABMF(1)=$PIECE($PIECE(ABMV("X1"),U),";",2)
- +1 IF $PIECE(ABMV("X1"),U,2)]""
- SET ABMF(2)=$PIECE(ABMV("X1"),U,2)
- SET ABMF(3)=$PIECE(ABMV("X1"),U,3)
- SET ABMF(4)=$PIECE(ABMV("X1"),U,4)
- +2 IF '$TEST
- SET ABMF(2)=$PIECE(ABMV("X1"),U,3)
- SET ABMF(3)=$PIECE(ABMV("X1"),U,4)
- SET ABMF(4)=$PIECE(ABMV("X1"),U,5)
- BNUM SET $PIECE(ABMF(2),U,3)=$PIECE(ABMP("B0"),U,1)_$SELECT($PIECE($GET(^ABMDPARM(DUZ(2),1,2)),U,4)]"":"-"_$PIECE(^(2),U,4),1:"")
- IF $PIECE($GET(^(3)),U,3)
- IF $PIECE($GET(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2)
- SET $PIECE(ABMF(2),U,3)=$PIECE(ABMF(2),U,3)_" "_$PIECE(^(0),U,2)
- BTYPE SET $PIECE(ABMF(2),U,4)=$SELECT($PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11):$PIECE($GET(^ABMDCODE($PIECE(^(0),U,11),0)),U),1:$PIECE(ABMP("B0"),U,2))
- INSNUM SET ABM("INUM")=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,8)
- +1 IF ABM("INUM")=""
- SET ABM("INUM")=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)
- +2 SET $PIECE(ABMF(4),U,$SELECT($PIECE($GET(^AUTNINS(ABMP("INS"),2)),U)="D":5,1:2))=ABM("INUM")
- TAX SET $PIECE(ABMF(4),U,3)=$PIECE(ABMV("X1"),U,6)
- +1 ;
- +2 ; Line 6
- PNODES SET ABM("P0")=^DPT(ABMP("PDFN"),0)
- SSN IF $PIECE(ABM("P0"),U,9)]""
- SET $PIECE(ABMF(12),U,12)=$SELECT($PIECE(ABM("P0"),U,9)'["-":$EXTRACT($PIECE(ABM("P0"),U,9),1,3)_"-"_$EXTRACT($PIECE(ABM("P0"),U,9),4,5)_"-"_$EXTRACT($PIECE(ABM("P0"),U,9),6,9),1:$PIECE(ABM("P0"),U,9))
- NAME SET ABMF(6)=$PIECE(ABM("P0"),U)
- ADDRESS SET $PIECE(ABMF(6),U,2)=$PIECE(ABMV("X2"),U,3)_" "_$PIECE(ABMV("X2"),U,4)
- +1 ;
- +2 ; Line 8
- DOB SET ABMF(8)=$PIECE(ABMV("X2"),U,6)
- SEX SET $PIECE(ABMF(8),U,2)=$PIECE(ABMV("X2"),U,2)
- MS SET $PIECE(ABMF(8),U,3)=$PIECE(ABMV("X2"),U,7)
- +1 KILL ABM("P0")
- +2 ;
- +3 GOTO ^ABMDF1A
- +4 ;
- XIT KILL ABM,ABMV,ABMF
- +1 QUIT
