ABMDE3 ; IHS/ASDST/DMJ - Edit Page 3 - QUESTIONS ;
;;2.6;IHS 3P BILLING SYSTEM;**6**;NOV 12, 2009
;
;IHS/DSD/DMJ - 4/27/1999 - NOIS QDA-0399-130056 Patch 1
; new code looks for y2k hcfa form (#14) at line QUES+6
;
; IHS/SD/SDR - v2.5 p8 - task 6 - Added code for new page 3A
; IHS/SD/SDR - abm*2.6*6 - 5010 - made code skip question 41 if not chiropractic clinic
; IHS/SD/SDR - abm*2.6*6 - 5010 - made code skip question 42 if not optometry clinic
;
; *********************************************************************
;
OPT ;EP
G XIT:$D(ABMP("WORKSHEET"))
K ABM,ABME,ABMZ,DUOUT,ABMP("QU")
S ABMP("OPT")="ENVJBQ"
D QUES
S ABMZ("NUM")=$L(ABMP("QU"),",")
D DISP
G XIT:$D(DTOUT)!$D(DIROUT)
D ^ABMDE3X
I +$O(ABME(0)) D
. S ABME("CONT")=""
. D ^ABMDERR
. K ABME("CONT")
G XIT:$D(DTOUT)!$D(DIROUT)
W !
D SEL^ABMDEOPT
G XIT:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!("EV"'[$E(Y))
S ABM("DO")=$S($E(Y)="E":"E1",1:"V1")
W !
D @ABM("DO")
G XIT:$D(DTOUT)!$D(DIROUT)
G OPT
;
; *********************************************************************
V1 ;
S ABMZ("TITL")="QUESTIONS - VIEW OPTION"
D SUM^ABMDE1
D ^ABMDERR
Q
;
; *********************************************************************
E1 ; Entry of Claim Identifiers
S ABMP("FLDS")=$L(ABMP("QU"),",")
I ABMP("QU")["13" S ABMP("FLDS")=ABMP("FLDS")-1
D FLDS^ABMDEOPT
Q:$D(DTOUT)!$D(DIROUT)!$D(DUOUT)
F ABM("I")=1:1 S ABM=$P(ABMP("FLDS"),",",ABM("I")) Q:'ABM D Q:$G(Y)[U
.S ABM=ABM\1
.S ABM("#")=ABM
.Q:'ABM
.S ABM("QU")=$P(ABMP("QU"),",",ABM)
.S ABM=+ABM("QU")
.D @($P(^ABMQUES(+ABM,0),"^",4)_"^"_$P(^(0),"^",5))
S DA=ABMP("CDFN")
S DIE="^ABMDCLM(DUZ(2),"
S DR=".09////Y"
D ^DIE
K DR
S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
Q
;
; *********************************************************************
QU K DIR,%P
F ABM("SUB")=1:1:12 D Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
. S ABM("SUB")=$S(ABM("SUB")<5:ABM("SUB")_"^ABMDE3A",1:ABM("SUB")_"^ABMDE3B")
. D @ABM("SUB")
G OPT
;
; *********************************************************************
DISP ;
S ABMZ("TITL")="QUESTIONS"
S ABMZ("PG")=3
I $D(ABMP("DDL")),$Y>(IOSL-6) D PAUSE^ABMDE1 Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) I 1
E D SUM^ABMDE1
F ABM("SUB")=1:1 S ABM("QU")=$P(ABMP("QU"),",",ABM("SUB")) Q:'ABM("QU") D Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
.I $Y>(IOSL-5) D PAUSE^ABMDE1 Q:$D(DUOUT)!$D(DTOUT)!$D(DIROUT)
.W !,$J("["_ABM("SUB")_"]",4)," "
.D @($P(^ABMQUES(+ABM("QU"),0),"^",2)_"^"_$P(^ABMQUES(+ABM("QU"),0),"^",3))
Q
;
; *********************************************************************
XIT K ABM,ABMP("QU")
Q
;
; *********************************************************************
QUES ;EP - for setting Questions Array
I '$D(ABMP("EXP")) D EXP^ABMDEVAR
S ABMP("QU")=""
S ABM("F")=0
F S ABM("F")=$O(ABMP("EXP",ABM("F"))) Q:'ABM("F") D
.S ABM("QU")=$G(ABM("QU"))_$S($P(^ABMDEXP(ABM("F"),0),U,8)]"":$P(^(0),U,8),1:"1,2,3,4,5,6,7,8,9,10,11,12,13")_","
.I $D(ABMP("EXP",3))!($D(ABMP("EXP",14))) D
..I $P($G(^AUTNINS(+$G(ABMP("INS")),2)),U)="D" S ABM("QU")=ABM("QU")_"14,"
..S ABM("QU")=ABM("QU")_"20,"
.S ABM("QU")=$P(ABM("QU"),",13",1)_$P(ABM("QU"),",13",2)
.F ABM("I")=1:1 S ABM=$P(ABM("QU"),",",ABM("I")) Q:ABM="" S ABM("QU",+ABM)=$P(ABM,+ABM,2)
S ABM=0
;F S ABM=$O(ABM("QU",ABM)) Q:'ABM S ABMP("QU")=$S(+ABMP("QU"):ABMP("QU")_",",1:"")_ABM_ABM("QU",ABM) ;abm*2.6*6 5010
;start new code abm*2.6*6 5010
F S ABM=$O(ABM("QU",ABM)) Q:'ABM D
.I ((ABM=41)&($P($G(^DIC(40.7,ABMP("CLN"),0)),U,2)'="A6")) Q ;only display if chiropractic clinic
.I ((ABM=42)&($P($G(^DIC(40.7,ABMP("CLN"),0)),U,2)'=18)) Q ;only display if optometry clinic
.S ABMP("QU")=$S(+ABMP("QU"):ABMP("QU")_",",1:"")_ABM_ABM("QU",ABM)
;end new code abm*2.6*6 5010
Q
3 ;
Q:$P($G(^DIC(40.7,ABMP("CLN"),0)),U)'="AMBULANCE"
D OPT^ABMDE31
I "Bb"[Y D OPT^ABMDE3
Q
ABMDE3 ; IHS/ASDST/DMJ - Edit Page 3 - QUESTIONS ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**6**;NOV 12, 2009
+2 ;
+3 ;IHS/DSD/DMJ - 4/27/1999 - NOIS QDA-0399-130056 Patch 1
+4 ; new code looks for y2k hcfa form (#14) at line QUES+6
+5 ;
+6 ; IHS/SD/SDR - v2.5 p8 - task 6 - Added code for new page 3A
+7 ; IHS/SD/SDR - abm*2.6*6 - 5010 - made code skip question 41 if not chiropractic clinic
+8 ; IHS/SD/SDR - abm*2.6*6 - 5010 - made code skip question 42 if not optometry clinic
+9 ;
+10 ; *********************************************************************
+11 ;
OPT ;EP
+1 IF $DATA(ABMP("WORKSHEET"))
GOTO XIT
+2 KILL ABM,ABME,ABMZ,DUOUT,ABMP("QU")
+3 SET ABMP("OPT")="ENVJBQ"
+4 DO QUES
+5 SET ABMZ("NUM")=$LENGTH(ABMP("QU"),",")
+6 DO DISP
+7 IF $DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
+8 DO ^ABMDE3X
+9 IF +$ORDER(ABME(0))
Begin DoDot:1
+10 SET ABME("CONT")=""
+11 DO ^ABMDERR
+12 KILL ABME("CONT")
End DoDot:1
+13 IF $DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
+14 WRITE !
+15 DO SEL^ABMDEOPT
+16 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!("EV"'[$EXTRACT(Y))
GOTO XIT
+17 SET ABM("DO")=$SELECT($EXTRACT(Y)="E":"E1",1:"V1")
+18 WRITE !
+19 DO @ABM("DO")
+20 IF $DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
+21 GOTO OPT
+22 ;
+23 ; *********************************************************************
V1 ;
+1 SET ABMZ("TITL")="QUESTIONS - VIEW OPTION"
+2 DO SUM^ABMDE1
+3 DO ^ABMDERR
+4 QUIT
+5 ;
+6 ; *********************************************************************
E1 ; Entry of Claim Identifiers
+1 SET ABMP("FLDS")=$LENGTH(ABMP("QU"),",")
+2 IF ABMP("QU")["13"
SET ABMP("FLDS")=ABMP("FLDS")-1
+3 DO FLDS^ABMDEOPT
+4 IF $DATA(DTOUT)!$DATA(DIROUT)!$DATA(DUOUT)
QUIT
+5 FOR ABM("I")=1:1
SET ABM=$PIECE(ABMP("FLDS"),",",ABM("I"))
IF 'ABM
QUIT
Begin DoDot:1
+6 SET ABM=ABM\1
+7 SET ABM("#")=ABM
+8 IF 'ABM
QUIT
+9 SET ABM("QU")=$PIECE(ABMP("QU"),",",ABM)
+10 SET ABM=+ABM("QU")
+11 DO @($PIECE(^ABMQUES(+ABM,0),"^",4)_"^"_$PIECE(^(0),"^",5))
End DoDot:1
IF $GET(Y)[U
QUIT
+12 SET DA=ABMP("CDFN")
+13 SET DIE="^ABMDCLM(DUZ(2),"
+14 SET DR=".09////Y"
+15 DO ^DIE
+16 KILL DR
+17 SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
+18 QUIT
+19 ;
+20 ; *********************************************************************
QU KILL DIR,%P
+1 FOR ABM("SUB")=1:1:12
Begin DoDot:1
+2 SET ABM("SUB")=$SELECT(ABM("SUB")<5:ABM("SUB")_"^ABMDE3A",1:ABM("SUB")_"^ABMDE3B")
+3 DO @ABM("SUB")
End DoDot:1
IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+4 GOTO OPT
+5 ;
+6 ; *********************************************************************
DISP ;
+1 SET ABMZ("TITL")="QUESTIONS"
+2 SET ABMZ("PG")=3
+3 IF $DATA(ABMP("DDL"))
IF $Y>(IOSL-6)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
IF 1
+4 IF '$TEST
DO SUM^ABMDE1
+5 FOR ABM("SUB")=1:1
SET ABM("QU")=$PIECE(ABMP("QU"),",",ABM("SUB"))
IF 'ABM("QU")
QUIT
Begin DoDot:1
+6 IF $Y>(IOSL-5)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+7 WRITE !,$JUSTIFY("["_ABM("SUB")_"]",4)," "
+8 DO @($PIECE(^ABMQUES(+ABM("QU"),0),"^",2)_"^"_$PIECE(^ABMQUES(+ABM("QU"),0),"^",3))
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT
+9 QUIT
+10 ;
+11 ; *********************************************************************
XIT KILL ABM,ABMP("QU")
+1 QUIT
+2 ;
+3 ; *********************************************************************
QUES ;EP - for setting Questions Array
+1 IF '$DATA(ABMP("EXP"))
DO EXP^ABMDEVAR
+2 SET ABMP("QU")=""
+3 SET ABM("F")=0
+4 FOR
SET ABM("F")=$ORDER(ABMP("EXP",ABM("F")))
IF 'ABM("F")
QUIT
Begin DoDot:1
+5 SET ABM("QU")=$GET(ABM("QU"))_$SELECT($PIECE(^ABMDEXP(ABM("F"),0),U,8)]"":$PIECE(^(0),U,8),1:"1,2,3,4,5,6,7,8,9,10,11,12,13")_","
+6 IF $DATA(ABMP("EXP",3))!($DATA(ABMP("EXP",14)))
Begin DoDot:2
+7 IF $PIECE($GET(^AUTNINS(+$GET(ABMP("INS")),2)),U)="D"
SET ABM("QU")=ABM("QU")_"14,"
+8 SET ABM("QU")=ABM("QU")_"20,"
End DoDot:2
+9 SET ABM("QU")=$PIECE(ABM("QU"),",13",1)_$PIECE(ABM("QU"),",13",2)
+10 FOR ABM("I")=1:1
SET ABM=$PIECE(ABM("QU"),",",ABM("I"))
IF ABM=""
QUIT
SET ABM("QU",+ABM)=$PIECE(ABM,+ABM,2)
End DoDot:1
+11 SET ABM=0
+12 ;F S ABM=$O(ABM("QU",ABM)) Q:'ABM S ABMP("QU")=$S(+ABMP("QU"):ABMP("QU")_",",1:"")_ABM_ABM("QU",ABM) ;abm*2.6*6 5010
+13 ;start new code abm*2.6*6 5010
+14 FOR
SET ABM=$ORDER(ABM("QU",ABM))
IF 'ABM
QUIT
Begin DoDot:1
+15 ;only display if chiropractic clinic
IF ((ABM=41)&($PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U,2)'="A6"))
QUIT
+16 ;only display if optometry clinic
IF ((ABM=42)&($PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U,2)'=18))
QUIT
+17 SET ABMP("QU")=$SELECT(+ABMP("QU"):ABMP("QU")_",",1:"")_ABM_ABM("QU",ABM)
End DoDot:1
+18 ;end new code abm*2.6*6 5010
+19 QUIT
3 ;
+1 IF $PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U)'="AMBULANCE"
QUIT
+2 DO OPT^ABMDE31
+3 IF "Bb"[Y
DO OPT^ABMDE3
+4 QUIT
