Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSEOBZ

ACHSEOBZ.m

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