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

ACHSEOB6.m

Go to the documentation of this file. 
  1. ACHSEOB6 ; IHS/ITSC/PMF - PROCESS EOBRS (7/7) SUMMARY/ERROR REPORT ;
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**13,18,22,23**;JUN 11,2001;Build 43
  1.  ;ACHS*3.1*13 JVK/SET/ITSC 8/22/05 FIX CLOSING SLAVE DEV
  1.  ;
  1. START ;EP - From TaskMan.
  1.  S ACHSSUM=0
  1.  S ACHS("R")=$O(^ACHSEOBR(0)),ACHSPG=0
  1.  G END:ACHS("R")=""
  1.  D SITENAME
  1.  S (ACHSFAC,ACHSOLD)="",ACHSEOIO=IO
  1.  K ^TMP("ACHSEOB",$J)
  1.  D BM^ACHSFU,NOW^ACHS
  1.  S X=ACHSTIME,ACHSTERR=0,ACHSLP=1  ;ACHS*3.1*22;ADDED ACHSLP
  1.  I ACHSRPT=1 S ACHSLP=0 W @IOF D HDR  ;ACHS*3.1*22;ADDED ACHSLP
  1.  I ACHSRPT=2 S ACHSFAC=0 G PRNT2
  1.  I ACHSISAO D AREA G END
  1.  F  S ACHSFAC=$O(^ACHSEOBR(ACHSFAC)) Q:+ACHSFAC'=ACHSFAC  D  Q:$D(DUOUT)!$D(DTOUT)
  1.  . ;ACHS*3.1*22 IHS.OIT.FCJ CHANGED NXT LINE TO START F LOOP TO ACHSLP VAR
  1.  . F ACHSCTR(1)=ACHSLP:0 Q:$D(DUOUT)!$D(DTOUT)  S ACHSCTR(1)=$O(^ACHSEOBR(ACHSFAC,ACHSCTR(1))) Q:+ACHSCTR(1)'=ACHSCTR(1)  S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18) D PRNT
  1.  .Q
  1.  Q:$D(DUOUT)!$D(DTOUT)          ;THIS USED TO BE A GOTO TO K^ACHSEOB5
  1.  W !?10,"TOTAL AMOUNT THIS RUN:        ",?40
  1.  S X=ACHSSUM
  1.  D FMT^ACHS
  1.  W !!!
  1.  D RTRN^ACHS:ACHSRPT=2,FTR:ACHSRPT=1
  1.  I ACHSRPT=1 D DCR
  1.  ;ACHS*3.1*13 ADDED TO PREVENT HANG OF SLAVE DEVICE JVK/SET/ITSC 8/22/05
  1.  D ^%ZISC
  1. END ;
  1.  I ACHSRPT=2 S ACHSRPT=1 G START
  1.  Q
  1.  ;
  1.  ;
  1. PRNT ;
  1.  F ACHSCTR=ACHSCTR(1):1 Q:'$D(^ACHSEOBR(ACHSFAC,ACHSCTR))  S ACHSEOBR=$G(^ACHSEOBR(ACHSFAC,ACHSCTR)) Q:$E(ACHSEOBR,1,18)'=ACHSOLD  D PRT^ACHSEOBB
  1.  I ACHSISAO Q:ACHSFAC'=ACHSFAC(1)
  1.  I ACHSRPT=2,'$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) Q
  1.  ;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q  ;ACHS*3.1*22
  1.  ;ACHS*3.1*23 ADDED K ACHSEOBR ARRAY IN NXT LINE
  1.  ;I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D:$P($G(ACHSMEDA),".",2)'="ICD" ^ACHSEOB2 K ^TMP("ACHSEOB",$J) Q  ;ACHS*3.1*22 DO NOT PRINT IF ICDFX
  1.  I ACHSRPT=2,$D(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1))) D:$P($G(ACHSMEDA),".",2)'="ICD" ^ACHSEOB2 S X=ACHSEOBR K ^TMP("ACHSEOB",$J),ACHSEOBR S ACHSEOBR=X Q  ;ACHS*3.1*23 CLEAN UP VARS
  1.  ;ACHS*3.1*23 TEST FOR DATA IN "B" REC
  1.  ;I $D(^ACHSEOBR(ACHSFAC,ACHSCTR(1))) D W1 W ?34,ACHSEOBR("B",8) D COST W !
  1.  I $D(^ACHSEOBR(ACHSFAC,ACHSCTR(1))),$D(ACHSEOBR("B",8)) D W1 W ?34,ACHSEOBR("B",8) D COST W !
  1. P0 ;
  1.  S ACHS="",ACHSER1=0
  1.  F  S ACHS=$O(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS)) Q:ACHS=""  D
  1.  . S ACHSER=$P($T(@ACHS^ACHSEOBG),";",4),ACHSDESC=$P($T(@ACHS^ACHSEOBG),";",3)
  1.  . I ACHSER="E" S ACHSSUM=ACHSSUM-ACHSCOST
  1.  . F I=1:1 S ACHSEDAT=$P(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1),ACHS),U,I) Q:(ACHSEDAT="")&(I>1)  W ?29,ACHSER_ACHS,?34,ACHSDESC W:ACHSEDAT]"" ?55,"(",ACHSEDAT,")" W ! S ACHSER1=1 Q:ACHSEDAT=""
  1. P1 ;
  1.  I ACHSRPT=2 D RTRN^ACHS
  1.  K ^TMP("ACHSEOB",$J),ACHSEOBR
  1.  I ACHSRPT=1,$Y>(ACHSBM-4) D FTR I '$D(DUOUT),'$D(DTOUT) D HDR
  1.  S ACHSCTR(1)=$S($D(^ACHSEOBR(ACHSFAC,ACHSCTR)):ACHSCTR-1,1:ACHSCTR)
  1.  Q
  1.  ;
  1. W1 ;
  1.  ;ACHS*3.1*22 ADDED TEST FOR DATA BELOW
  1.  W:$D(ACHSEOBR("A")) $J(+ACHSEOBR("A",8),5),?6,ACHSEOBR("A",14)," ",$E(ACHSEOBR("A",12),2,12)," "," ",ACHSEOBR("C",13)," "," "," ",ACHSEOBR("A",15)," "
  1.  Q
  1.  ;
  1. COST ;
  1.  ;ACHS*3.1*23 CHG "E" TO VAR ACHSREJ FOR REC E OR J
  1.  S ACHSREJ=$S($D(ACHSEOBR("E")):"E",$D(ACHSEOBR("J")):"J",1:"")
  1.  W ?70,$J($FN(+$E(ACHSEOBR(ACHSREJ,8),1,7)_"."_$E(ACHSEOBR(ACHSREJ,8),8,9),",",2),8)
  1.  S ACHSCOST=$E(ACHSEOBR(ACHSREJ,8),1,7)_"."_$E(ACHSEOBR(ACHSREJ,8),8,9)
  1.  S ACHSSUM=ACHSSUM+ACHSCOST
  1.  Q
  1.  ;
  1. PRNT2 ;
  1.  S ACHSFAC=$O(^ACHSEOBR("ER",ACHSFAC))
  1.  G END:ACHSFAC=""
  1.  W @IOF
  1.  S ACHSCTR(1)=0
  1. PRNT2A ;
  1.  S ACHSCTR(1)=$O(^ACHSEOBR("ER",ACHSFAC,ACHSCTR(1)))
  1.  G PRNT2:ACHSCTR(1)=""
  1.  S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18)
  1.  D PRNT,RTRN^ACHS
  1.  Q:$D(DUOUT)!$D(DTOUT)       ;USED TO BE G K^ACHSEOB5
  1.  G PRNT2A
  1.  ;
  1. HDR ;
  1.  U IO
  1.  S ACHSPG=ACHSPG+1
  1.  W ACHSTIME,?28,"CHS EOBR PROCESSING REPORT",?67,"PAGE ",$J(ACHSPG,3),!,?24,"for Documents Paid on: ",$$FMTE^XLFDT(ACHSEOBD),!,?40-(($L(ACHS("SITE"))+4)\2),"for ",ACHS("SITE"),!
  1. HDR2 ;
  1.  W !!,"COUNT SITE   P.O. NUMBER P-T CODE DESCRIPTION or PATIENT",?70,"IHS COST",!,"----- ------ ----------- --- ---- ------------------------------",?70,"--------",!!
  1.  Q
  1.  ;
  1. SITENAME ;
  1.  S ACHS("SITE")=$P(^DIC(4,ACHS("R"),0),U,1)
  1.  Q
  1.  ;
  1. FTR ; Print footer, do EOP, TOP.
  1.  W !,"'COUNT' appears at the upper right of the EOBR.",!,"If 'CODE' begins with 'E', the P.O. was not processed.",!,"If 'CODE' begins with 'W', the P.O. was processed but needs further attention.",!
  1.  D RTRN^ACHS
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  W @IOF
  1.  Q
  1.  ;
  1. AREA ;
  1.  S (ACHSFAC,ACHSCTR,ACHSCTR(1),ACHSFAC(1))=0
  1. AREA1 ;
  1.  S ACHSFAC=$O(^ACHSEOBR(ACHSFAC))
  1.  Q:+ACHSFAC'=ACHSFAC
  1.  Q:ACHSFAC=""
  1.  S ACHS("R")=ACHSFAC
  1.  D SITENAME
  1.  I ACHSFAC'=ACHSFAC(1),ACHSFAC(1)'=0 D FTR Q:$D(DUOUT)!$D(DTOUT)  D HDR
  1. AREA2 ;
  1.  S ACHSCTR(1)=$O(^ACHSEOBR(ACHSFAC,ACHSCTR(1)))
  1.  G AREA1:ACHSCTR(1)=""
  1.  S ACHSOLD=$E(^ACHSEOBR(ACHSFAC,ACHSCTR(1)),1,18),ACHSFAC(1)=ACHSFAC
  1.  D PRNT
  1.  Q:$D(DUOUT)!$D(DTOUT)       ;USED TO BE G K^ACHSEOB5
  1.  G AREA2
  1.  ;
  1. DCR ; Print Begin/End values of DCRs
  1.  N %,B,E,N,R,X,Y
  1.  S N=$G(^ACHS(9,DUZ(2),"RN")),Y=0
  1.  F  S Y=$O(^ACHSEOBR("DCR",Y)) Q:'Y  D  Q:$G(ACHSQUIT)
  1.  . I '$D(^ACHSEOBR("DCR",Y,"E")) S ^ACHSEOBR("DCR",Y,"E")=$G(^ACHSEOBR("DCR",Y,"B"))
  1.  . I $G(^ACHSEOBR("DCR",Y,"B"))=$G(^ACHSEOBR("DCR",Y,"E")) Q
  1.  . S B=$G(^ACHSEOBR("DCR",Y,"B"))
  1.  . S E=$G(^ACHSEOBR("DCR",Y,"E"))
  1.  . W !!,Y," Registers",?29,"Before",?45,"After",?59,"Change"
  1.  . W !,$$R(20),?22,$$R(13),?37,$$R(13),?52,$$R(13)
  1.  . F %=1:1:7 S R=$P(N,U,%)_$$REPEAT^XLFSTR(".",20) W !,$E(R,1,20),$J($FN($P(B,U,%),",",2),15),$J($FN($P(E,U,%),",",2),15),$J($FN($P(B,U,%)-$P(E,U,%),",",2),15)
  1.  . D RTRN
  1.  .Q
  1.  Q
  1.  ;
  1. R(A) ;
  1.  Q $$REPEAT^XLFSTR("-",A)
  1.  ;
  1. RTRN ;
  1.  N %,B,E,N,R,X,Y
  1.  D RTRN^ACHS
  1.  Q