ACHSEOBZ ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (5/6) - UPDATE DOCUMENT(2/2) ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22**;JUN 11, 2001;Build 43
;CALLED BY ACHSEOB4
;
;
CPTREV ;EP - Process EOBR CPT / REVENUE / ADA codes.
N ACHSX,ACHSY,ACHSDIC
S ACHS=0
C1 ;
S ACHS=$O(^TMP("ACHSEOB",$J,"F",ACHS))
Q:'ACHS
S ACHSMRCA="" ; NO WARNING MESSAGE FOR REV/CPT/ADA YET
S ACHSEOBR("F")=$G(^TMP("ACHSEOB",$J,"F",ACHS))
S ACHSX=$E(ACHSEOBR("F"),39,43) ;PROCEDURE CODE
S ACHSX=$$STRIP^XLFSTR(ACHSX," ")
;
;IF LENGTH IS 5 ASSUME 'CPT' FILE GLOBAL ^ICPT(
;IF LENGTH IS 4 ASSUME 'ADA CODE' FILE GLOBAL ^AUTTADA(
;IF LENGTH IS 3 ASSUME 'REVENUE CODES' FILE GLOBAL ^AUTTREVN(
;OTHERWISE ASSUME A GLOBAL DON'T LOOK FOR SPECIAL LOOKUP
S X=$S($L(ACHSX)=5:81,$L(ACHSX)=4:9999999.31,$L(ACHSX)=3:9999999.72,1:""),DIC(0)="M"
I X]"" S X=$G(^DD(X,0,"DIC")) ;IS THERE A SPECIAL LOOKUP PROGRAM?
I X]"" X ^%ZOSF("TEST") E S DIC(0)="IM" ;CHECK TO SEE IF RTN EXISTS
;
S DIC=$S($L(ACHSX)=5:"^ICPT(",$L(ACHSX)=4:"^AUTTADA(",1:"^AUTTREVN(")
;
S X=ACHSX I $E(X,1)?1A S X="~"_X
;
I $L(ACHSX)=5 S Y=$P($$CPT^ICPTCOD(ACHSX),U,1,2) G C2 ;ACHS*3.1*18 IHS.OIT.FCJ CSV CHANGES
D ^DIC
;
C2 ;ACHS*3.1*18 NEW LINE
S ACHSY=Y
S ACHSDIC=DIC
;
;IF FOUND IN TABLE THEN ADD TO DOCUMENT FILE
I +Y>0 D DOCUMENT(ACHSX,ACHSY,ACHSDIC) G C1
;
G REV:$L(ACHSX)=3 ;ADD REVENUE CODE
G ADA:$L(ACHSX)=4 ;ADD ADA CODE
G CPT ;ADD CPT CODE
;
REV ; Add missing Revenue Code.
S ACHSERRE=19
S ACHSEDAT=ACHSX
D ^ACHSEOBG
S DIC=ACHSDIC
S X="PT CONVENCE/OTH"
D ^DIC
S ACHSMRCA="WARNING: REV["_ACHSEDAT_"] FAILED, USING["_X_"]"
D DOCUMENT(X,Y,DIC)
G C1
;
ADA ; Add missing ADA code.
S ACHSERRE=33
S ACHSEDAT=ACHSX
D ^ACHSEOBG ;ERROR MESSAGE STUFF
S DIC=ACHSDIC
S X="UNSPECIFIED TREATMENT"
D ^DIC
S ACHSMRCA="WARNING: ADA["_ACHSEDAT_"] FAILED, USING["_X_"]"
D DOCUMENT(X,Y,DIC)
G C1
;
CPT ; Add missing CPT code.
S ACHSERRE=18
S ACHSEDAT=ACHSX
D ^ACHSEOBG
S DIC=ACHSDIC
S X="UNCODED"
S DIC(0)="MI"
D ^DIC
S DIC(0)="M"
S ACHSMRCA="WARNING: CPT["_ACHSEDAT_"] FAILED, USING["_X_"]"
D DOCUMENT(X,Y,DIC)
G C1
;
DOCUMENT(ACHSX,ACHSY,ACHSDIC) ; Add EOBR info to CPT/REV/ADA multiple in DOCUMENT multiple.
;
N ACHSDR,ACHSFDA,I,DR,ACHSTMP
;
D REC2^ACHSEOBB(ACHSEOBR("F"),.ACHSEOBR) ; set new "F" in array
S ACHSDR(1)=ACHSEOBR("F",8)-17000000 ; DOS to
S ACHSDR(2)=ACHSEOBR("F",9)-17000000 ; DOS from
S ACHSDR(3)=+ACHSEOBR("F",11) ; Unit #
S ACHSDR(4)=+$E(ACHSEOBR("F",12),1,7)_"."_$E(ACHSEOBR("F",12),8,9) ; Charges billed
S ACHSDR(5)=+$E(ACHSEOBR("F",13),1,7)_"."_$E(ACHSEOBR("F",13),8,9) ; Charges allowable
S (ACHSMSG,ACHSDR(6))=$P(ACHSEOBR("F",14)," ") ; Message
S ACHSDR(7)=$P(ACHSEOBR("F",15)," ") ; Tooth number
S ACHSDR(8)=$P(ACHSEOBR("F",16)," ") ; Tooth surface
S ACHSDR(10)=ACHSTDA ;EOBR transaction number
;
CK ; Following code creates DR and tmp string that will resemble what
; will be in the document file before it is set
; This allows a check against the file itself for possible duplicates
; If it does find a duplicate, it sets error code and quits
S I=0,DR="",ACHSTMP=U
F S I=$O(ACHSDR(I)) Q:I="" D
.S:DR'="" DR=DR_";"
.S DR=DR_I_"////"_ACHSDR(I),ACHSTMP=ACHSTMP_U_ACHSDR(I)
;Set achsdr=to entire data string for comparison
K ACHSDR S ACHSDR=+ACHSY_";"_$P($P(ACHSDIC,"("),U,2)_"("_ACHSTMP
S I=0 F S I=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,I)) Q:'I D
.I $P(ACHSDR,1,U,6)=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,11,I,0),U,1,6) D Q
..S ACHSERRE=8,ACHSEDAT=DR D ^ACHSEOBG Q
Q:$G(ACHSERRE)=8 ; Do not set duplicate transactions
D SET
Q
;
SET ;Check/create zero/.01 nodes X/Y set in C1,REV,ADA or CPT
N X,Y,DIC,DA,ACHSDICP
S X=$P(ACHSDR,U,1),DIC(0)="",DA(1)=ACHSDIEN,DA(2)=DUZ(2)
S DIC="^ACHSF("_DA(2)_","_"""D"""_","_DA(1)_",11,"
S (ACHSDICP,DIC("P"))=$P(^DD(9002080.01,97,0),U,2)
K DO,DD D FILE^DICN
I Y<1 S ACHSERRE=$S(+ACHSX>999:18,1:19),ACHSEDAT=ACHSX D ^ACHSEOBG Q
S (ACHSDA,DA)=+Y ;Save da for use in msgset
S DIE=DIC
D ^DIE
I $G(Y)]"" D
.S ACHSERRE=$S(ACHSDIC["CPT":18,ACHSDIC["ADA":33,1:19)
.S ACHSEDAT=ACHSX D ^ACHSEOBG
D:ACHSMRCA]"" MSGSET(ACHSMRCA) ;Special error message text
D:ACHSMSG]"" NEXT,MSGSET(ACHSMSG) ; Message from FI
Q
MSGSET(X) ; Set message node
Q:X="" ; ACHSMSG can be reset in NEXT
S DIC(0)="",DA(2)=ACHSDIEN,DA(3)=DUZ(2),DA(1)=ACHSDA
S DIC="^ACHSF("_DA(3)_","_"""D"""_","_DA(2)_",11,"_DA(1)_",1,"
S (ACHSDICP,DIC("P"))=$P(^DD(9002080.197,9,0),U,2)
K DO,DD D FILE^DICN
I Y<1 S ACHSERRE=$S(+ACHSX>999:18,1:19),ACHSEDAT=ACHSX D ^ACHSEOBG Q
Q
;
NEXT ;Prepare for messages
;
Q ;ACHS*3.1*23 MESSAGES ARE SENT IN THE "F" RECORD WHICH IS ALREADY SET ABOVE
N ACHSX
F ACHSX=1:2 Q:'$D(^TMP("ACHSEOB",$J,"G",ACHSX)) D
.S ACHSEOBR("G")=$G(^TMP("ACHSEOB",$J,"G",ACHSX))
.I ACHSMSG=$E(ACHSEOBR("G"),1,4) D
..S ACHSMSG=ACHSMSG_" -"_$E(ACHSEOBR("G"),5,99)
S:ACHSMSG'["-" ACHSMSG="" ; No special message in G record
Q
ACHSEOBZ ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (5/6) - UPDATE DOCUMENT(2/2) ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22**;JUN 11, 2001;Build 43
+2 ;CALLED BY ACHSEOB4
+3 ;
+4 ;
CPTREV ;EP - Process EOBR CPT / REVENUE / ADA codes.
+1 NEW ACHSX,ACHSY,ACHSDIC
+2 SET ACHS=0
C1 ;
+1 SET ACHS=$ORDER(^TMP("ACHSEOB",$JOB,"F",ACHS))
+2 IF 'ACHS
QUIT
+3 ; NO WARNING MESSAGE FOR REV/CPT/ADA YET
SET ACHSMRCA=""
+4 SET ACHSEOBR("F")=$GET(^TMP("ACHSEOB",$JOB,"F",ACHS))
+5 ;PROCEDURE CODE
SET ACHSX=$EXTRACT(ACHSEOBR("F"),39,43)
+6 SET ACHSX=$$STRIP^XLFSTR(ACHSX," ")
+7 ;
+8 ;IF LENGTH IS 5 ASSUME 'CPT' FILE GLOBAL ^ICPT(
+9 ;IF LENGTH IS 4 ASSUME 'ADA CODE' FILE GLOBAL ^AUTTADA(
+10 ;IF LENGTH IS 3 ASSUME 'REVENUE CODES' FILE GLOBAL ^AUTTREVN(
+11 ;OTHERWISE ASSUME A GLOBAL DON'T LOOK FOR SPECIAL LOOKUP
+12 SET X=$SELECT($LENGTH(ACHSX)=5:81,$LENGTH(ACHSX)=4:9999999.31,$LENGTH(ACHSX)=3:9999999.72,1:"")
SET DIC(0)="M"
+13 ;IS THERE A SPECIAL LOOKUP PROGRAM?
IF X]""
SET X=$GET(^DD(X,0,"DIC"))
+14 ;CHECK TO SEE IF RTN EXISTS
IF X]""
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET DIC(0)="IM"
+15 ;
+16 SET DIC=$SELECT($LENGTH(ACHSX)=5:"^ICPT(",$LENGTH(ACHSX)=4:"^AUTTADA(",1:"^AUTTREVN(")
+17 ;
+18 SET X=ACHSX
IF $EXTRACT(X,1)?1A
SET X="~"_X
+19 ;
+20 ;ACHS*3.1*18 IHS.OIT.FCJ CSV CHANGES
IF $LENGTH(ACHSX)=5
SET Y=$PIECE($$CPT^ICPTCOD(ACHSX),U,1,2)
GOTO C2
+21 DO ^DIC
+22 ;
C2 ;ACHS*3.1*18 NEW LINE
+1 SET ACHSY=Y
+2 SET ACHSDIC=DIC
+3 ;
+4 ;IF FOUND IN TABLE THEN ADD TO DOCUMENT FILE
+5 IF +Y>0
DO DOCUMENT(ACHSX,ACHSY,ACHSDIC)
GOTO C1
+6 ;
+7 ;ADD REVENUE CODE
IF $LENGTH(ACHSX)=3
GOTO REV
+8 ;ADD ADA CODE
IF $LENGTH(ACHSX)=4
GOTO ADA
+9 ;ADD CPT CODE
GOTO CPT
+10 ;
REV ; Add missing Revenue Code.
+1 SET ACHSERRE=19
+2 SET ACHSEDAT=ACHSX
+3 DO ^ACHSEOBG
+4 SET DIC=ACHSDIC
+5 SET X="PT CONVENCE/OTH"
+6 DO ^DIC
+7 SET ACHSMRCA="WARNING: REV["_ACHSEDAT_"] FAILED, USING["_X_"]"
+8 DO DOCUMENT(X,Y,DIC)
+9 GOTO C1
+10 ;
ADA ; Add missing ADA code.
+1 SET ACHSERRE=33
+2 SET ACHSEDAT=ACHSX
+3 ;ERROR MESSAGE STUFF
DO ^ACHSEOBG
+4 SET DIC=ACHSDIC
+5 SET X="UNSPECIFIED TREATMENT"
+6 DO ^DIC
+7 SET ACHSMRCA="WARNING: ADA["_ACHSEDAT_"] FAILED, USING["_X_"]"
+8 DO DOCUMENT(X,Y,DIC)
+9 GOTO C1
+10 ;
CPT ; Add missing CPT code.
+1 SET ACHSERRE=18
+2 SET ACHSEDAT=ACHSX
+3 DO ^ACHSEOBG
+4 SET DIC=ACHSDIC
+5 SET X="UNCODED"
+6 SET DIC(0)="MI"
+7 DO ^DIC
+8 SET DIC(0)="M"
+9 SET ACHSMRCA="WARNING: CPT["_ACHSEDAT_"] FAILED, USING["_X_"]"
+10 DO DOCUMENT(X,Y,DIC)
+11 GOTO C1
+12 ;
DOCUMENT(ACHSX,ACHSY,ACHSDIC) ; Add EOBR info to CPT/REV/ADA multiple in DOCUMENT multiple.
+1 ;
+2 NEW ACHSDR,ACHSFDA,I,DR,ACHSTMP
+3 ;
+4 ; set new "F" in array
DO REC2^ACHSEOBB(ACHSEOBR("F"),.ACHSEOBR)
+5 ; DOS to
SET ACHSDR(1)=ACHSEOBR("F",8)-17000000
+6 ; DOS from
SET ACHSDR(2)=ACHSEOBR("F",9)-17000000
+7 ; Unit #
SET ACHSDR(3)=+ACHSEOBR("F",11)
+8 ; Charges billed
SET ACHSDR(4)=+$EXTRACT(ACHSEOBR("F",12),1,7)_"."_$EXTRACT(ACHSEOBR("F",12),8,9)
+9 ; Charges allowable
SET ACHSDR(5)=+$EXTRACT(ACHSEOBR("F",13),1,7)_"."_$EXTRACT(ACHSEOBR("F",13),8,9)
+10 ; Message
SET (ACHSMSG,ACHSDR(6))=$PIECE(ACHSEOBR("F",14)," ")
+11 ; Tooth number
SET ACHSDR(7)=$PIECE(ACHSEOBR("F",15)," ")
+12 ; Tooth surface
SET ACHSDR(8)=$PIECE(ACHSEOBR("F",16)," ")
+13 ;EOBR transaction number
SET ACHSDR(10)=ACHSTDA
+14 ;
CK ; Following code creates DR and tmp string that will resemble what
+1 ; will be in the document file before it is set
+2 ; This allows a check against the file itself for possible duplicates
+3 ; If it does find a duplicate, it sets error code and quits
+4 SET I=0
SET DR=""
SET ACHSTMP=U
+5 FOR
SET I=$ORDER(ACHSDR(I))
IF I=""
QUIT
Begin DoDot:1
+6 IF DR'=""
SET DR=DR_";"
+7 SET DR=DR_I_"////"_ACHSDR(I)
SET ACHSTMP=ACHSTMP_U_ACHSDR(I)
End DoDot:1
+8 ;Set achsdr=to entire data string for comparison
+9 KILL ACHSDR
SET ACHSDR=+ACHSY_";"_$PIECE($PIECE(ACHSDIC,"("),U,2)_"("_ACHSTMP
+10 SET I=0
FOR
SET I=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,11,I))
IF 'I
QUIT
Begin DoDot:1
+11 IF $PIECE(ACHSDR,1,U,6)=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,11,I,0),U,1,6)
Begin DoDot:2
+12 SET ACHSERRE=8
SET ACHSEDAT=DR
DO ^ACHSEOBG
QUIT
End DoDot:2
QUIT
End DoDot:1
+13 ; Do not set duplicate transactions
IF $GET(ACHSERRE)=8
QUIT
+14 DO SET
+15 QUIT
+16 ;
SET ;Check/create zero/.01 nodes X/Y set in C1,REV,ADA or CPT
+1 NEW X,Y,DIC,DA,ACHSDICP
+2 SET X=$PIECE(ACHSDR,U,1)
SET DIC(0)=""
SET DA(1)=ACHSDIEN
SET DA(2)=DUZ(2)
+3 SET DIC="^ACHSF("_DA(2)_","_"""D"""_","_DA(1)_",11,"
+4 SET (ACHSDICP,DIC("P"))=$PIECE(^DD(9002080.01,97,0),U,2)
+5 KILL DO,DD
DO FILE^DICN
+6 IF Y<1
SET ACHSERRE=$SELECT(+ACHSX>999:18,1:19)
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
QUIT
+7 ;Save da for use in msgset
SET (ACHSDA,DA)=+Y
+8 SET DIE=DIC
+9 DO ^DIE
+10 IF $GET(Y)]""
Begin DoDot:1
+11 SET ACHSERRE=$SELECT(ACHSDIC["CPT":18,ACHSDIC["ADA":33,1:19)
+12 SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
End DoDot:1
+13 ;Special error message text
IF ACHSMRCA]""
DO MSGSET(ACHSMRCA)
+14 ; Message from FI
IF ACHSMSG]""
DO NEXT
DO MSGSET(ACHSMSG)
+15 QUIT
MSGSET(X) ; Set message node
+1 ; ACHSMSG can be reset in NEXT
IF X=""
QUIT
+2 SET DIC(0)=""
SET DA(2)=ACHSDIEN
SET DA(3)=DUZ(2)
SET DA(1)=ACHSDA
+3 SET DIC="^ACHSF("_DA(3)_","_"""D"""_","_DA(2)_",11,"_DA(1)_",1,"
+4 SET (ACHSDICP,DIC("P"))=$PIECE(^DD(9002080.197,9,0),U,2)
+5 KILL DO,DD
DO FILE^DICN
+6 IF Y<1
SET ACHSERRE=$SELECT(+ACHSX>999:18,1:19)
SET ACHSEDAT=ACHSX
DO ^ACHSEOBG
QUIT
+7 QUIT
+8 ;
NEXT ;Prepare for messages
+1 ;
+2 ;ACHS*3.1*23 MESSAGES ARE SENT IN THE "F" RECORD WHICH IS ALREADY SET ABOVE
QUIT
+3 NEW ACHSX
+4 FOR ACHSX=1:2
IF '$DATA(^TMP("ACHSEOB",$JOB,"G",ACHSX))
QUIT
Begin DoDot:1
+5 SET ACHSEOBR("G")=$GET(^TMP("ACHSEOB",$JOB,"G",ACHSX))
+6 IF ACHSMSG=$EXTRACT(ACHSEOBR("G"),1,4)
Begin DoDot:2
+7 SET ACHSMSG=ACHSMSG_" -"_$EXTRACT(ACHSEOBR("G"),5,99)
End DoDot:2
End DoDot:1
+8 ; No special message in G record
IF ACHSMSG'["-"
SET ACHSMSG=""
+9 QUIT
