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

ACHSEOBF.m

Go to the documentation of this file. 
  1. ACHSEOBF ; IHS/ITSC/TPF/PMF - SET VARIABLE FROM DOCUMENT FOR EOBR PRNTING ; JUL 10, 2008  
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,15,23**;JUN 11,2001;Build 43
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1.  ;3.1*15 11.04.2008 IHS/OIT/FCJ FIXED PRINTING TOTALS
  1.  ;3.1*23 9.19.2013 	IHS/OIT/FCJ ADDED PROC FOR ICD-10
  1.  ;
  1. F ;EP
  1.  ;F ARRAY
  1.  ;F DETAIL RECORD
  1.  F I=8:1:16 S ACHSEOBR("F",I)=""   ;INIT ARRAY
  1.  ;
  1.  ;BELOW GOES THROUGHT THE CPT OR REV INFORMATION SUB FILE OF THE 
  1.  ;DOCUMENT FILE
  1.  ;
  1. F1 ;
  1.  S ACHSCNTR=7    ;INIT F DETAIL FIELD NUMBER
  1.  S ACHSCPT=0
  1.  S ACHSCSEQ=0    ;INIT SEQUENCE NUMBER FOR CPTS
  1.  F  S ACHSCPT=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSCPT)) Q:+ACHSCPT=0  D
  1.  .Q:$P(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSCPT,0),U,10)'=ACHSTIEN
  1.  .S X=$J("",22)
  1.  .S $E(X,19)="F" ; SET THE RECORD TYPE FOR ACHSEOBB
  1.  .;beginning Y2K fix
  1.  .S ACHSCSEQ=ACHSCSEQ+1 ;Y2000
  1.  .;Y2000 use CCYYMMDD format in the following record generation
  1.  .;
  1.  .;GET CPT SUBFILE 0 RECORD
  1.  .S ACHSCPT0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSCPT,0))
  1.  .Q:'ACHSCPT0     ;IF NO ZERO RECORD NOTHING TO DO
  1.  .;
  1.  .;ACHS*3.1*15 11/4/2008 IHS/OIT/FCJ FIX PRINTING VAULES AT THE BOTTEM OF PAGE
  1.  .;S ^TMP("ACHSEOB",$J,"F",ACHSCSEQ)=X_$P(ACHSCPT0,U,2)+17000000_$P(^(0),U,3)+17000000   ;Y2000  ;DATE OF SERVICE FROM
  1.  .S ^TMP("ACHSEOB",$J,"F",ACHSCSEQ)=X_($P(ACHSCPT0,U,2)+17000000)_($P(ACHSCPT0,U,3)+17000000)   ;Y2000  ;DATE OF SERVICE
  1.  .;end Y2K fix block
  1.  .;
  1.  .S A=$P($P(ACHSCPT0,U),";",1),A=$J(" ",5)_A,A=$E(A,$L(A)-4,$L(A)) ;CPT/REVENUE CODE
  1.  .S B=$P(ACHSCPT0,U,4),B=$J(" ",2)_B,B=$E(B,$L(B)-2,$L(B))         ;UNITS
  1.  .S D=$P(ACHSCPT0,U,5)   ;CHARGES BILLED
  1.  .S X=""
  1.  .F I=1:1:$L(D) I $E(D,I)'="." S X=X_$E(D,I)   ;FORMAT OUT DECIMAL
  1.  .S D=X,D="000000000"_D,D=$E(D,$L(D)-8,$L(D))  ;FILL OUT D TO 8 PLACES
  1.  .S E=$P(ACHSCPT0,U,6)                         ;CHARGES ALLOWABLE
  1.  .S X=""
  1.  .F I=1:1:$L(E) I $E(E,I)'="." S X=X_$E(E,I)
  1.  .S E=X,E="000000000"_E,E=$E(E,$L(E)-8,$L(E))
  1.  .S F=$P(ACHSCPT0,U,7)                          ;MSG CODE
  1.  .S F=$J(" ",4)_F,F=$E(F,$L(F)-3,$L(F))
  1.  .S G=$P(ACHSCPT0,U,8)                          ;TOOTH NUMBER
  1.  .S G=$J(" ",2)_G,G=$E(G,$L(G)-2,$L(G))
  1.  .S H=$P(ACHSCPT0,U,9)                          ;TOOTH SURFACE
  1.  .S H=$J(" ",5)_H,H=$E(H,$L(H)-5,$L(H))
  1.  .;
  1.  .;CONSOLIDATE ALL TEMP VARS INTO THE TMP GLOBAL F DETAIL RECORD
  1.  .S ^TMP("ACHSEOB",$J,"F",ACHSCSEQ)=$G(^TMP("ACHSEOB",$J,"F",ACHSCSEQ))_A_B_D_E_F_G_H
  1.  .;
  1.  .S ACHSEOBR("F",8)=$P(ACHSCPT0,U,2)            ;DOS FROM
  1.  .S ACHSEOBR("F",9)=$P(ACHSCPT0,U,3)            ;DOS TO
  1.  .S ACHSEOBR("F",10)=$P($P(ACHSCPT0,U,1),";",1) ;CPT/REV CODE
  1.  .S ACHSEOBR("F",11)=$P(ACHSCPT0,U,4)           ;UNITS  
  1.  .S ACHSEOBR("F",12)=$P(ACHSCPT0,U,5)           ;CHARGES BILLED
  1.  .S ACHSEOBR("F",13)=$P(ACHSCPT0,U,6)           ;CHARGES ALLOWABLE
  1.  .S ACHSEOBR("F",14)=$P(ACHSCPT0,U,7)           ;MSG CODE
  1.  .S ACHSEOBR("F",15)=$P(ACHSCPT0,U,8)           ;TOOTH NUMBER
  1.  .S ACHSEOBR("F",16)=$P(ACHSCPT0,U,9)           ;TOOTH SURFACE
  1.  .;
  1.  .;"D",9 IS AN ACCUMULATOR (BILLED BY PROV) ADD UP CHARGES BILLED 
  1.  .I ACHSEOBR("F",14)'="" S ACHSEOBR("M","B",ACHSEOBR("F",14))=""
  1.  .S ACHSEOBR("D",9)=ACHSEOBR("D",9)+ACHSEOBR("F",12)
  1.  .I ACHSEOBR("D",9)'["." S ACHSEOBR("D",9)=ACHSEOBR("D",9)_".00"
  1.  .;
  1.  .;"D",10 IS AN ACCUMULATOR (ALLOWABLE AMT) ADD UP CHARGES ALLOWABLE
  1.  .S ACHSEOBR("D",10)=ACHSEOBR("D",10)+ACHSEOBR("F",13)
  1.  .I ACHSEOBR("D",10)'["." S ACHSEOBR("D",10)=ACHSEOBR("D",10)_".00"
  1.  .;
  1.  .;IF EOBR SERVICES BILLED="B" INPATIENT THEN TAKE DIFFERENCE BETWEEN
  1.  .;DOS FROM AND DOS TO., IF THIS IS NOT EQUAL TO "B" THE VARIABLE WAS
  1.  .;ALREADY SET TO THE WORKLOAD FIELD $P(ACHSTRAN,U,9) IN ACHSEOBA
  1.  .I ACHSEOBR("C",10)="B",ACHSCPT=1 S X1=ACHSEOBR("F",9),X2=ACHSEOBR("F",8) D ^%DTC S ACHSEOBR("B",11)=X
  1.  ;
  1.  ;
  1.  ;G ARRAY
  1.  ;G PROCEDURES ARRAY 
  1. G ;
  1.  ;ACHS*3.1*23 CHANGED FOR LOOP FROM 10 TO 12
  1.  F I=8:1:12 S ACHSEOBR("G",I)=""  ;INIT ARRAY
  1.  ;
  1. G1 ;GO THRU PROCEDURE RECORDS AND PULL INFO
  1.  S ACHSCNTR=7     ;INTITALIZE MAINFRAM FIELD NUMBER FOR ARRAY
  1.  S ACHSPROC=0
  1.  F  S ACHSPROC=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHSPROC)) Q:+ACHSPROC=0  D
  1.  .;GET PROCEDURE 0 RECORD
  1.  .S ACHSPRC0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,10,ACHSPROC,0))
  1.  .Q:$P(ACHSPRC0,U,3)'=ACHSTIEN   ;EOBR TRANSACTION # MUST MATCH 
  1.  .S ACHSCNTR=ACHSCNTR+1
  1.  .S ACHSEOBR("G",ACHSCNTR)=$P(ACHSPRC0,U)     ;PROCEDURE PTR
  1.  .Q:ACHSEOBR("G",ACHSCNTR)=""
  1.  .;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
  1.  .;S ACHSEOBR("G",ACHSCNTR)=$P($G(^ICD0(ACHSEOBR("G",ACHSCNTR),0)),U)  ;PROC CODE
  1.  .;S ACHSEOBR("G",ACHSCNTR)=$P($$ICDOP^ICDCODE(ACHSEOBR("G",ACHSCNTR)),U,2)  ;PROC CODE ;ACHS*3.1*23
  1.  .S ACHSEOBR("G",ACHSCNTR)=$P($$ICDOP^ICDEX(ACHSEOBR("G",ACHSCNTR),,,"I"),U,2)  ;PROC CODE ;ACHS*3.1*23
  1.  ;
  1.  ;
  1. J ;LOOP THRU TRANSACTION SUBFILE OF DOCUMENT FILE
  1.  I $D(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA")) S ACHSPA=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,"PA"),U,6)   ;'FINAL PAYMENT AMOUNT'
  1.  S (ACHSTR,ACHSOBG,ACHSPA)=0
  1. J1 F  S ACHSTR=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTR)) Q:+ACHSTR=0  D
  1.  .;GET TRANSACTION 0 RECORD
  1.  .S ACHSTRA0=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTR,0))
  1.  .Q:ACHSTRA0=""
  1.  .;
  1.  .;IF TRANSACTION TYPE IS "INITIAL" ADD TO OBLIGATION AMT
  1.  .I $P(ACHSTRA0,U,2)="I" S ACHSOBG=ACHSOBG+$P(ACHSTRA0,U,4)
  1.  .;
  1.  .;IF TRANSACTION TYPE IS "SUPPLEMENTAL" ADD TO OBLIGATION AMT
  1.  .I $P(ACHSTRA0,U,2)="S" S ACHSOBG=ACHSOBG+$P(ACHSTRA0,U,4)
  1.  .;
  1.  .;IF TRANSACTION TYPE IS "CANCELATION" SUBTRACT FROM OBLIGATION AMT
  1.  .I $P(ACHSTRA0,U,2)="C" S ACHSOBG=ACHSOBG-$P(ACHSTRA0,U,4)
  1.  .;
  1.  .;IF TRANSACTION TYPE IS "INTERIM PAYMENT" IGNORE
  1.  .;I $P(ACHSTRA0,U,2)="IP" S ACHSPA=ACHSPA+$P(ACHSTRA0,U,4)
  1.  .;
  1.  .;IF TRANSACTION TYPE IS "ADJUSTMENT" ADD TO UNITS BILLED
  1.  .I $P(ACHSTRA0,U,2)="ZA" S ACHSPA=ACHSPA+$P(ACHSTRA0,U,4)
  1.  .;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  .S ACHSEOBR(ACHSREJ,10)=ACHSOBG
  1.  .S ACHSEOBR(ACHSREJ,11)=ACHSPA
  1.  .S ACHSEOBR(ACHSREJ,11)=ACHSOBG-ACHSPA  ;UNITS BILLED=OBLIGATION-ADJUSTMENT
  1.  .;
  1.  .;EOBR PAY TYPE   'I'=INTERIM  'F'=FINAL 
  1.  .;IF INTERIM WIPE OUT OBLIGATION AND ADJUSTMENT AMT   ??????
  1.  .;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  .I $P(ACHSTRAN,U,15)="I" S (ACHSEOBR(ACHSREJ,10),ACHSEOBR(ACHSREJ,11))="*********" Q    ;IF WIPEING OUT WHY BOTHER WITH NEXT TWO LINES?
  1.  .I ACHSEOBR(ACHSREJ,10)["." S %=ACHSEOBR(ACHSREJ,10),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR(ACHSREJ,10)=%
  1.  .E  S ACHSEOBR(ACHSREJ,10)=ACHSEOBR(ACHSREJ,10)_"00"
  1.  .I ACHSEOBR(ACHSREJ,11)["." S %=ACHSEOBR(ACHSREJ,11),%=$P(%,".")_$E($P(%,".",2)_"00",1,2),ACHSEOBR(ACHSREJ,11)=%
  1.  .E  S ACHSEOBR(ACHSREJ,11)=ACHSEOBR(ACHSREJ,11)_"00"
  1.  Q
  1.  ;