ABMDF1B ; IHS/ASDST/DMJ - Set UB82 Print Array - cont ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
S ABM("X")=DT D DT S $P(ABMF(63),U,3)=ABM("X")
10 ; Line 10
S ABM=0 F ABM("I")=1:2:10 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM)) Q:'ABM D OCCUR
S ABM=0 F ABM("I")=11:1:13 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM)) Q:'ABM D SPAN
G 12
;
OCCUR S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM,0),U,2) D DT Q:ABM("X")=""
S $P(ABMF(10),U,ABM("I"))=$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM,0),U),0),U)
S $P(ABMF(10),U,ABM("I")+1)=ABM("X")
Q
;
SPAN S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U,2) Q:ABM("X")="" D DT S ABM("X0")=ABM("X")
S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U,3) Q:ABM("X")="" D DT
I ABM("I")=11 S $P(ABMF(10),U,11)=$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U),0),U)
I S $P(ABMF(10),U,12)=ABM("X0"),$P(ABMF(10),U,13)=ABM("X")
E S ABMP("REM",ABM("I"))="Occurance Span: "_$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U),0),U)_" "_ABM("X0")_" to "_ABM("X")
Q
;
12 ; Line 12
S ABM=0 F ABM("I")=2:1:6 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),53,ABM)) Q:'ABM S $P(ABMF(12),U,ABM("I"))=$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),53,ABM,0),U),0),U)
;
S ABM=0 F ABM("I")=1:1:2 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM)) Q:'ABM D SPROG
G VALU
;
SPROG S ABM("X")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U,1) Q:ABM("X")=""
I ABM("I")=1 S $P(ABMF(12),U,11)=$P(^ABMDCODE(ABM("X"),0),U)
E S ABMP("REM",ABM("I"))="Special Program: "_$P(^ABMDCODE(ABM("X"),0),U)
Q
;
VALU ; Value Codes
I $D(^AUTNINS(ABMP("INS"),2)),$P(^(2),U,1)'="R" G REM
14 S ABM=0 F ABM("I")=2:2:8 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM)) Q:'ABM S $P(ABMF(14),U,ABM("I"))=$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM,0),U),0),U)_U_$P(^(0),U,2)
15 S ABM="" F ABM("I")=2:2:8 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM)) Q:'ABM S $P(ABMF(15),U,ABM("I"))=$P(^ABMDCODE($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM,0),U),0),U)_U_$P(^(0),U,2)
;
REM S ABM=0 F ABM("I")=1:1 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABM)) Q:'ABM
S ABM("I")=$S(ABM("I")<3:60,ABM("I")<5:59,1:58)
S ABM=0 F ABM("I")=ABM("I"):1:63 S ABM=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABM)) Q:'ABM S $P(ABMF(ABM("I")),U)=^(ABM,0)
I ABM("I")>63 G CONT
S ABM("I")=$S(ABM("I")<60:60,1:ABM("I")),$P(ABMF(ABM("I")),U)="Send Payment to Provider (see Block 1)"
I ABM("I")<63 S $P(ABMF(ABM("I")+1),U)="--------------------------------------"
;
CONT K ABM,ABMV,ABMX
G ^ABMDF1C
;
DT I ABM("X")]"" S ABM("X")=$E(ABM("X"),4,5)_"-"_$E(ABM("X"),6,7)_"-"_$E(ABM("X"),2,3)
Q
ABMDF1B ; IHS/ASDST/DMJ - Set UB82 Print Array - cont ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 SET ABM("X")=DT
DO DT
SET $PIECE(ABMF(63),U,3)=ABM("X")
10 ; Line 10
+1 SET ABM=0
FOR ABM("I")=1:2:10
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM))
IF 'ABM
QUIT
DO OCCUR
+2 SET ABM=0
FOR ABM("I")=11:1:13
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM))
IF 'ABM
QUIT
DO SPAN
+3 GOTO 12
+4 ;
OCCUR SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM,0),U,2)
DO DT
IF ABM("X")=""
QUIT
+1 SET $PIECE(ABMF(10),U,ABM("I"))=$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),51,ABM,0),U),0),U)
+2 SET $PIECE(ABMF(10),U,ABM("I")+1)=ABM("X")
+3 QUIT
+4 ;
SPAN SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U,2)
IF ABM("X")=""
QUIT
DO DT
SET ABM("X0")=ABM("X")
+1 SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U,3)
IF ABM("X")=""
QUIT
DO DT
+2 IF ABM("I")=11
SET $PIECE(ABMF(10),U,11)=$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U),0),U)
+3 IF $TEST
SET $PIECE(ABMF(10),U,12)=ABM("X0")
SET $PIECE(ABMF(10),U,13)=ABM("X")
+4 IF '$TEST
SET ABMP("REM",ABM("I"))="Occurance Span: "_$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),57,ABM,0),U),0),U)_" "_ABM("X0")_" to "_ABM("X")
+5 QUIT
+6 ;
12 ; Line 12
+1 SET ABM=0
FOR ABM("I")=2:1:6
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),53,ABM))
IF 'ABM
QUIT
SET $PIECE(ABMF(12),U,ABM("I"))=$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),53,ABM,0),U),0),U)
+2 ;
+3 SET ABM=0
FOR ABM("I")=1:1:2
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM))
IF 'ABM
QUIT
DO SPROG
+4 GOTO VALU
+5 ;
SPROG SET ABM("X")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),59,ABM,0),U,1)
IF ABM("X")=""
QUIT
+1 IF ABM("I")=1
SET $PIECE(ABMF(12),U,11)=$PIECE(^ABMDCODE(ABM("X"),0),U)
+2 IF '$TEST
SET ABMP("REM",ABM("I"))="Special Program: "_$PIECE(^ABMDCODE(ABM("X"),0),U)
+3 QUIT
+4 ;
VALU ; Value Codes
+1 IF $DATA(^AUTNINS(ABMP("INS"),2))
IF $PIECE(^(2),U,1)'="R"
GOTO REM
14 SET ABM=0
FOR ABM("I")=2:2:8
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM))
IF 'ABM
QUIT
SET $PIECE(ABMF(14),U,ABM("I"))=$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM,0),U),0),U)_U_$PIECE(^(0),U,2)
15 SET ABM=""
FOR ABM("I")=2:2:8
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM))
IF 'ABM
QUIT
SET $PIECE(ABMF(15),U,ABM("I"))=$PIECE(^ABMDCODE($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),55,ABM,0),U),0),U)_U_$PIECE(^(0),U,2)
+1 ;
REM SET ABM=0
FOR ABM("I")=1:1
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABM))
IF 'ABM
QUIT
+1 SET ABM("I")=$SELECT(ABM("I")<3:60,ABM("I")<5:59,1:58)
+2 SET ABM=0
FOR ABM("I")=ABM("I"):1:63
SET ABM=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),61,ABM))
IF 'ABM
QUIT
SET $PIECE(ABMF(ABM("I")),U)=^(ABM,0)
+3 IF ABM("I")>63
GOTO CONT
+4 SET ABM("I")=$SELECT(ABM("I")<60:60,1:ABM("I"))
SET $PIECE(ABMF(ABM("I")),U)="Send Payment to Provider (see Block 1)"
+5 IF ABM("I")<63
SET $PIECE(ABMF(ABM("I")+1),U)="--------------------------------------"
+6 ;
CONT KILL ABM,ABMV,ABMX
+1 GOTO ^ABMDF1C
+2 ;
DT IF ABM("X")]""
SET ABM("X")=$EXTRACT(ABM("X"),4,5)_"-"_$EXTRACT(ABM("X"),6,7)_"-"_$EXTRACT(ABM("X"),2,3)
+1 QUIT
