ABMDF2B ; IHS/ASDST/DMJ - Set HCFA1500 Print Array PART 2 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
;IHS/DSD/DMJ - 5/14/1999 - NOIS HQW-0599-100027 Patch 2
; Y2K IV&V issues, all $$HDT^ABMDUTL changed to $$HDTO^ABMDUTL
; in lines: EMPL+2,EMPL+3,EMPL+4,EMPL+5,EMPL+6,FSYM
; FCONS,SIML,LAB+3,ADMIT,DISCH
;
BNODES S ABM("B5")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),5)),ABM("B6")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),6)),ABM("B7")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),ABM("B8")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),ABM("B9")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9))
I $P(ABM("B5"),U,8)]"" S $P(ABMF(34),U,2)=$P(ABM("B5"),U,8)
EMPL I $P(ABM("B9"),U,1)]"" S $P(ABMF(13),U,2)="X"
E S $P(ABMF(13),U,3)="X" G ACCD
I $P(ABM("B9"),U,2)]"" S $P(ABMF(25),U,1)=$$HDTO^ABMDUTL($P(ABM("B9"),U,2))
I $P(ABM("B9"),U,3)]"" S $P(ABMF(25),U,2)=$$HDTO^ABMDUTL($P(ABM("B9"),U,3))
I $P(ABM("B9"),U,4)]"" S $P(ABMF(25),U,3)=$$HDTO^ABMDUTL($P(ABM("B9"),U,4))
I $P(ABM("B9"),U,5)]"" S $P(ABMF(25),U,4)=$$HDTO^ABMDUTL($P(ABM("B9"),U,5))
I $P(ABM("B9"),U,6)]"" S $P(ABMF(25),U,5)=$$HDTO^ABMDUTL($P(ABM("B9"),U,6))
;
ACCD I $P(ABM("B8"),U,3)]"" S:"12"[$P(ABM("B8"),U,3) $P(ABMF(16),U,2)="X" S:"12"'[$P(ABM("B8"),U,3) $P(ABMF(16),U,3)="X"
FSYM I $P(ABM("B8"),U,6)]"" S $P(ABMF(23),U,1)=$$HDTO^ABMDUTL($P(ABM("B8"),U,6))
FCONS I $P(ABM("B8"),U,7)]"" S $P(ABMF(23),U,2)=$$HDTO^ABMDUTL($P(ABM("B8"),U,7))
SIML I $P(ABM("B8"),U,9)]"" S $P(ABMF(23),U,3)=$$HDTO^ABMDUTL($P(ABM("B8"),U,9))
REFR I $P(ABM("B8"),U,8)]"" S $P(ABMF(27),U,1)=$P(ABM("B8"),U,8)
EMER I $P(ABM("B8"),U,5)]"" S $P(ABMF(23),U,4)="X"
LAB I $P(ABM("B8"),U,1)]"" S $P(ABMF(29),U,2)="X",$P(ABMF(29),U,4)=$P(ABM("B8"),U,1)
E S $P(ABMF(29),U,3)="X"
I $P(ABM("B7"),U,5)="Y" S ABMF("19")="SIGNATURE ON FILE"
I $P(ABM("B7"),U,4)="Y" S ABMF("20")="SIGNATURE ON FILE"_U_$$HDTO^ABMDUTL(DT)
;
I $P(ABMP("B0"),U,7)'=111 G DAYS
;
; Hosp Info
ADMIT I $P(ABM("B6"),U,1)]"" S $P(ABMF(27),U,2)=$$HDTO^ABMDUTL($P(ABM("B6"),U,1))
DISCH I $P(ABM("B6"),U,3)]"" S $P(ABMF(27),U,3)=$$HDTO^ABMDUTL($P(ABM("B6"),U,3))
;
DAYS ; Service Periods
S ABM=0 F ABM("I")=1:1 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM)) Q:'ABM D
.S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U,1) Q:ABM("X")=""
.I $P(^ABMDCODE(ABM("X"),0),U)["EPSDT" S $P(ABMF(31),U,2)="X"
.I $P(^ABMDCODE(ABM("X"),0),U)["FAMILY " S $P(ABMF(32),U,2)="X"
.Q
I $P($G(ABMF(31)),U,2)="" S $P(ABMF(31),U,3)="X"
I $P($G(ABMF(32)),U,2)="" S $P(ABMF(32),U,3)="X"
;
CONT K ABM,ABMV,ABMX
G ^ABMDF2C
;
XIT Q
ABMDF2B ; IHS/ASDST/DMJ - Set HCFA1500 Print Array PART 2 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 ;IHS/DSD/DMJ - 5/14/1999 - NOIS HQW-0599-100027 Patch 2
+5 ; Y2K IV&V issues, all $$HDT^ABMDUTL changed to $$HDTO^ABMDUTL
+6 ; in lines: EMPL+2,EMPL+3,EMPL+4,EMPL+5,EMPL+6,FSYM
+7 ; FCONS,SIML,LAB+3,ADMIT,DISCH
+8 ;
BNODES SET ABM("B5")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),5))
SET ABM("B6")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),6))
SET ABM("B7")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7))
SET ABM("B8")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8))
SET ABM("B9")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9))
+1 IF $PIECE(ABM("B5"),U,8)]""
SET $PIECE(ABMF(34),U,2)=$PIECE(ABM("B5"),U,8)
EMPL IF $PIECE(ABM("B9"),U,1)]""
SET $PIECE(ABMF(13),U,2)="X"
+1 IF '$TEST
SET $PIECE(ABMF(13),U,3)="X"
GOTO ACCD
+2 IF $PIECE(ABM("B9"),U,2)]""
SET $PIECE(ABMF(25),U,1)=$$HDTO^ABMDUTL($PIECE(ABM("B9"),U,2))
+3 IF $PIECE(ABM("B9"),U,3)]""
SET $PIECE(ABMF(25),U,2)=$$HDTO^ABMDUTL($PIECE(ABM("B9"),U,3))
+4 IF $PIECE(ABM("B9"),U,4)]""
SET $PIECE(ABMF(25),U,3)=$$HDTO^ABMDUTL($PIECE(ABM("B9"),U,4))
+5 IF $PIECE(ABM("B9"),U,5)]""
SET $PIECE(ABMF(25),U,4)=$$HDTO^ABMDUTL($PIECE(ABM("B9"),U,5))
+6 IF $PIECE(ABM("B9"),U,6)]""
SET $PIECE(ABMF(25),U,5)=$$HDTO^ABMDUTL($PIECE(ABM("B9"),U,6))
+7 ;
ACCD IF $PIECE(ABM("B8"),U,3)]""
IF "12"[$PIECE(ABM("B8"),U,3)
SET $PIECE(ABMF(16),U,2)="X"
IF "12"'[$PIECE(ABM("B8"),U,3)
SET $PIECE(ABMF(16),U,3)="X"
FSYM IF $PIECE(ABM("B8"),U,6)]""
SET $PIECE(ABMF(23),U,1)=$$HDTO^ABMDUTL($PIECE(ABM("B8"),U,6))
FCONS IF $PIECE(ABM("B8"),U,7)]""
SET $PIECE(ABMF(23),U,2)=$$HDTO^ABMDUTL($PIECE(ABM("B8"),U,7))
SIML IF $PIECE(ABM("B8"),U,9)]""
SET $PIECE(ABMF(23),U,3)=$$HDTO^ABMDUTL($PIECE(ABM("B8"),U,9))
REFR IF $PIECE(ABM("B8"),U,8)]""
SET $PIECE(ABMF(27),U,1)=$PIECE(ABM("B8"),U,8)
EMER IF $PIECE(ABM("B8"),U,5)]""
SET $PIECE(ABMF(23),U,4)="X"
LAB IF $PIECE(ABM("B8"),U,1)]""
SET $PIECE(ABMF(29),U,2)="X"
SET $PIECE(ABMF(29),U,4)=$PIECE(ABM("B8"),U,1)
+1 IF '$TEST
SET $PIECE(ABMF(29),U,3)="X"
+2 IF $PIECE(ABM("B7"),U,5)="Y"
SET ABMF("19")="SIGNATURE ON FILE"
+3 IF $PIECE(ABM("B7"),U,4)="Y"
SET ABMF("20")="SIGNATURE ON FILE"_U_$$HDTO^ABMDUTL(DT)
+4 ;
+5 IF $PIECE(ABMP("B0"),U,7)'=111
GOTO DAYS
+6 ;
+7 ; Hosp Info
ADMIT IF $PIECE(ABM("B6"),U,1)]""
SET $PIECE(ABMF(27),U,2)=$$HDTO^ABMDUTL($PIECE(ABM("B6"),U,1))
DISCH IF $PIECE(ABM("B6"),U,3)]""
SET $PIECE(ABMF(27),U,3)=$$HDTO^ABMDUTL($PIECE(ABM("B6"),U,3))
+1 ;
DAYS ; Service Periods
+1 SET ABM=0
FOR ABM("I")=1:1
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+2 SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U,1)
IF ABM("X")=""
QUIT
+3 IF $PIECE(^ABMDCODE(ABM("X"),0),U)["EPSDT"
SET $PIECE(ABMF(31),U,2)="X"
+4 IF $PIECE(^ABMDCODE(ABM("X"),0),U)["FAMILY "
SET $PIECE(ABMF(32),U,2)="X"
+5 QUIT
End DoDot:1
+6 IF $PIECE($GET(ABMF(31)),U,2)=""
SET $PIECE(ABMF(31),U,3)="X"
+7 IF $PIECE($GET(ABMF(32)),U,2)=""
SET $PIECE(ABMF(32),U,3)="X"
+8 ;
CONT KILL ABM,ABMV,ABMX
+1 GOTO ^ABMDF2C
+2 ;
XIT QUIT
