ABMDAST1 ; IHS/ASDST/DMJ - APC VISIT STUFF - PART 2 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;
; IHS/SD/SDR - v2.6 CSV
;
I $O(^DIC(40.7,"B","EMERGENCY MEDICINE",""))=ABMP("CLN") S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0) D ASET^ABMDE3B
I $O(^DIC(40.7,"B","EPSDT",""))=ABMP("CLN") S Y=67 D SP^ABMDE3B
I $O(^DIC(40.7,"B","FAMILY PLANNING",""))=ABMP("CLN") S Y=70 D SP^ABMDE3B
I $P($G(^AAPCRCDS(ABMP("VDFN"),2)),U,28)]"" S DIE="^ABMDCLM(DUZ(2),",DA=ABMP("CDFN"),ABM("Y")=$S(+$P(^(2),U,28)=1:1,1:5),DR=".82////"_ABMP("VDT")_";.83////"_ABM("Y"),ABM("X")=ABMP("VDT") D ^DIE K DR D ACCODE^ABMDE3A
;
S ABM=0,ABM("P")=1
F ABM("P")=ABM("P"):1 S ABM=$O(^AAPCRCDS(ABMP("VDFN"),3,ABM)) Q:'ABM S ABM("X")=+^AAPCRCDS(ABMP("VDFN"),3,ABM,0) D
.Q:'$D(^AAPCRECD(ABM("X"),0)) S ABM("CD")=$E($P(^AAPCRECD(ABM("X"),0),U,2),3,99)
.S ABM("Y")="UNK"
.S ABM("SAVE")=ABM("CD") I $D(^ICD9("B")) D
..D LOOK1
..S:$D(^ICD9(+X,0)) ABM("Y")=+X
.I ABM("Y")="UNK" S ABM("CD")=ABM("SAVE") D
..D LOOK2
..S:$D(^ICD9(+X,0)) ABM("Y")=+X
.I ABM("Y") D POVCK
G ^ABMDAST2
;
POVCK ; SCREEN OUT E CODES AND INACTIVE CODES
SEX I $P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,11)]"",$P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,11)'=$P(^DPT(ABMP("PDFN"),0),U,2) Q ;CSV-c
AGE S X1=ABMP("VDT"),X2=$P(^DPT(ABMP("PDFN"),0),U,3) D ^%DTC
I $D(^ICD9(ABM("Y"),9999999)) Q:$P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,15)]""&(X>($P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,15))) Q:$P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,16)]""&(X>($P($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,16))) ;CSV-c
;
POVOK Q:$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM("Y"),0))
S X=$P(^AAPCRECD(ABM("X"),0),U,3)
S DIC=9999999.27,DIC(0)="XL" D ^DIC Q:Y<0 S ABM("NAR")=+Y
I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,"C",ABM("P")))=10 S ABMR="" F S ABMR=$O(^(ABMR)) Q:ABMR="" S ABM("P")=ABMR+1
S (DINUM,X)=ABM("Y")
S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,",DIC(0)="LE" K DD,DO
S DIC("P")=$P(^DD(9002274.3,17,0),U,2)
S DIC("DR")=".02////"_ABM("P")_";.03////"_ABM("NAR") K DD,DO D FILE^DICN
Q
;
LOOK1 ; Lookup using "B" x-ref
I $L(ABM("CD"))>3 S ABM("CD")=$E(ABM("CD"),1,3)_"."_$E(ABM("CD"),4,5)
S X=$O(^ICD9("B",ABM("CD"),"")) Q:X
I $E(ABM("CD"),$L(ABM("CD")))=0 D
.S ABM("ZCD")=""""_""""_ABM("CD")_""""_"""",X=$O(^ICD9("B",ABM("ZCD"),"")) K ABM("ZCD") Q:X
I $L(ABM("CD"))>3 S ABM("CD")=ABM("CD")_" ",X=$O(^ICD9("B",ABM("CD"),"")) Q:X
I $L(ABM("CD"))<4 S ABM("ZCD")=ABM("CD")_".",X=$O(^ICD9("B",ABM("ZCD"),"")) K ABM("ZCD") Q:X
I $L(ABM("CD"))<4 S ABM("CD")=ABM("CD")_". ",X=$O(^ICD9("B",ABM("CD"),""))
Q
;
LOOK2 ; Lookup using "BA" x-ref
S ABM("Y")="UNK"
I $L(ABM("CD"))>3 S ABM("CD")=$E(ABM("CD"),1,3)_"."_$E(ABM("CD"),4,5)
S X=$O(^ICD9("BA",ABM("CD"),"")) Q:X
I $E(ABM("CD"),$L(ABM("CD")))=0 D
.S ABM("ZCD")=""""_""""_ABM("CD")_""""_"""",X=$O(^ICD9("BA",ABM("ZCD"),"")) K ABM("ZCD") Q:X
I $L(ABM("CD"))>3 S ABM("CD")=ABM("CD")_" ",X=$O(^ICD9("BA",ABM("CD"),"")) Q:X
I $L(ABM("CD"))<4 S ABM("ZCD")=ABM("CD")_".",X=$O(^ICD9("BA",ABM("ZCD"),"")) K ABM("ZCD") Q:X
I $L(ABM("CD"))<4 S ABM("CD")=ABM("CD")_". ",X=$O(^ICD9("BA",ABM("CD"),""))
Q
ABMDAST1 ; IHS/ASDST/DMJ - APC VISIT STUFF - PART 2 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;
+3 ; IHS/SD/SDR - v2.6 CSV
+4 ;
+5 IF $ORDER(^DIC(40.7,"B","EMERGENCY MEDICINE",""))=ABMP("CLN")
SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
DO ASET^ABMDE3B
+6 IF $ORDER(^DIC(40.7,"B","EPSDT",""))=ABMP("CLN")
SET Y=67
DO SP^ABMDE3B
+7 IF $ORDER(^DIC(40.7,"B","FAMILY PLANNING",""))=ABMP("CLN")
SET Y=70
DO SP^ABMDE3B
+8 IF $PIECE($GET(^AAPCRCDS(ABMP("VDFN"),2)),U,28)]""
SET DIE="^ABMDCLM(DUZ(2),"
SET DA=ABMP("CDFN")
SET ABM("Y")=$SELECT(+$PIECE(^(2),U,28)=1:1,1:5)
SET DR=".82////"_ABMP("VDT")_";.83////"_ABM("Y")
SET ABM("X")=ABMP("VDT")
DO ^DIE
KILL DR
DO ACCODE^ABMDE3A
+9 ;
+10 SET ABM=0
SET ABM("P")=1
+11 FOR ABM("P")=ABM("P"):1
SET ABM=$ORDER(^AAPCRCDS(ABMP("VDFN"),3,ABM))
IF 'ABM
QUIT
SET ABM("X")=+^AAPCRCDS(ABMP("VDFN"),3,ABM,0)
Begin DoDot:1
+12 IF '$DATA(^AAPCRECD(ABM("X"),0))
QUIT
SET ABM("CD")=$EXTRACT($PIECE(^AAPCRECD(ABM("X"),0),U,2),3,99)
+13 SET ABM("Y")="UNK"
+14 SET ABM("SAVE")=ABM("CD")
IF $DATA(^ICD9("B"))
Begin DoDot:2
+15 DO LOOK1
+16 IF $DATA(^ICD9(+X,0))
SET ABM("Y")=+X
End DoDot:2
+17 IF ABM("Y")="UNK"
SET ABM("CD")=ABM("SAVE")
Begin DoDot:2
+18 DO LOOK2
+19 IF $DATA(^ICD9(+X,0))
SET ABM("Y")=+X
End DoDot:2
+20 IF ABM("Y")
DO POVCK
End DoDot:1
+21 GOTO ^ABMDAST2
+22 ;
POVCK ; SCREEN OUT E CODES AND INACTIVE CODES
SEX ;CSV-c
IF $PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,11)]""
IF $PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,11)'=$PIECE(^DPT(ABMP("PDFN"),0),U,2)
QUIT
AGE SET X1=ABMP("VDT")
SET X2=$PIECE(^DPT(ABMP("PDFN"),0),U,3)
DO ^%DTC
+1 ;CSV-c
IF $DATA(^ICD9(ABM("Y"),9999999))
IF $PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,15)]""&(X>($PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,15)))
QUIT
IF $PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,16)]""&(X>($PIECE($$DX^ABMCVAPI(ABM("Y"),ABMP("VDT")),U,16)))
QUIT
+2 ;
POVOK IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,ABM("Y"),0))
QUIT
+1 SET X=$PIECE(^AAPCRECD(ABM("X"),0),U,3)
+2 SET DIC=9999999.27
SET DIC(0)="XL"
DO ^DIC
IF Y<0
QUIT
SET ABM("NAR")=+Y
+3 IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),17,"C",ABM("P")))=10
SET ABMR=""
FOR
SET ABMR=$ORDER(^(ABMR))
IF ABMR=""
QUIT
SET ABM("P")=ABMR+1
+4 SET (DINUM,X)=ABM("Y")
+5 SET DA(1)=ABMP("CDFN")
SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",17,"
SET DIC(0)="LE"
KILL DD,DO
+6 SET DIC("P")=$PIECE(^DD(9002274.3,17,0),U,2)
+7 SET DIC("DR")=".02////"_ABM("P")_";.03////"_ABM("NAR")
KILL DD,DO
DO FILE^DICN
+8 QUIT
+9 ;
LOOK1 ; Lookup using "B" x-ref
+1 IF $LENGTH(ABM("CD"))>3
SET ABM("CD")=$EXTRACT(ABM("CD"),1,3)_"."_$EXTRACT(ABM("CD"),4,5)
+2 SET X=$ORDER(^ICD9("B",ABM("CD"),""))
IF X
QUIT
+3 IF $EXTRACT(ABM("CD"),$LENGTH(ABM("CD")))=0
Begin DoDot:1
+4 SET ABM("ZCD")=""""_""""_ABM("CD")_""""_""""
SET X=$ORDER(^ICD9("B",ABM("ZCD"),""))
KILL ABM("ZCD")
IF X
QUIT
End DoDot:1
+5 IF $LENGTH(ABM("CD"))>3
SET ABM("CD")=ABM("CD")_" "
SET X=$ORDER(^ICD9("B",ABM("CD"),""))
IF X
QUIT
+6 IF $LENGTH(ABM("CD"))<4
SET ABM("ZCD")=ABM("CD")_"."
SET X=$ORDER(^ICD9("B",ABM("ZCD"),""))
KILL ABM("ZCD")
IF X
QUIT
+7 IF $LENGTH(ABM("CD"))<4
SET ABM("CD")=ABM("CD")_". "
SET X=$ORDER(^ICD9("B",ABM("CD"),""))
+8 QUIT
+9 ;
LOOK2 ; Lookup using "BA" x-ref
+1 SET ABM("Y")="UNK"
+2 IF $LENGTH(ABM("CD"))>3
SET ABM("CD")=$EXTRACT(ABM("CD"),1,3)_"."_$EXTRACT(ABM("CD"),4,5)
+3 SET X=$ORDER(^ICD9("BA",ABM("CD"),""))
IF X
QUIT
+4 IF $EXTRACT(ABM("CD"),$LENGTH(ABM("CD")))=0
Begin DoDot:1
+5 SET ABM("ZCD")=""""_""""_ABM("CD")_""""_""""
SET X=$ORDER(^ICD9("BA",ABM("ZCD"),""))
KILL ABM("ZCD")
IF X
QUIT
End DoDot:1
+6 IF $LENGTH(ABM("CD"))>3
SET ABM("CD")=ABM("CD")_" "
SET X=$ORDER(^ICD9("BA",ABM("CD"),""))
IF X
QUIT
+7 IF $LENGTH(ABM("CD"))<4
SET ABM("ZCD")=ABM("CD")_"."
SET X=$ORDER(^ICD9("BA",ABM("ZCD"),""))
KILL ABM("ZCD")
IF X
QUIT
+8 IF $LENGTH(ABM("CD"))<4
SET ABM("CD")=ABM("CD")_". "
SET X=$ORDER(^ICD9("BA",ABM("CD"),""))
+9 QUIT
