ACHSEOB2 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (3/6) - PRINT EOBR ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**21,23**;JUN 11, 2001;Build 43
;ACHS*3.1*23 CHANGED E RECORD TO TEST FOR E OR J AND USE VAR ACHSREJ
;
I ACHSEOIO'=IO S IOP=ACHSEOIO D ^%ZIS ;ACHS*3.1*21
S ACHSREJ=$S($D(ACHSEOBR("E")):"E",$D(ACHSEOBR("J")):"J",1:"") ;ACHS*3.1*23
U ACHSEOIO
W @IOF
I $P($P(^%ZIS(2,IOST(0),0),U,1),"-",1)="P",($D(^%ZIS(2,IOST(0),5))),$L($P(^(5),U,2)),$L($P(^(5),U,1)) W @($P(^%ZIS(2,IOST(0),5),U,2)) S IOM=90
W !!?20,"+++ EXPLANATION OF BENEFITS REPORT +++",!,ACHSTIME
W !?5,"INDIAN HEALTH SERVICE",?47,"CONTRACT HEALTH SERVICES",!
;
I +ACHSEOBR("A",8) W ?62,"CLAIM SEQ. COUNT ",$J(+$G(ACHSEOBR("A",8)),9) ;CLAIM SEQUENCE COUNT
A ;
W !!,"AREA OFFICE: ",$E($P(^AUTTAREA($O(^AUTTAREA("C",ACHSEOBR("A",1),0)),0),U),1,17)
W ?34,"CHECK NUMB.: ",$G(ACHSEOBR("A",9))
W !!,"SERVICE UNIT: ",$E($P(^AUTTSU($O(^AUTTSU("C",ACHSEOBR("A",1)_ACHSEOBR("A",2),0)),0),U),1,17)
;
; Labels begin in col 1 and 35.
; Begin print info in col 20 and 48.
;
W ?34,"REMITTANCE.: ",$G(ACHSEOBR("A",10))
W ?64,"DATE: ",$E(ACHSEOBR("A",11),5,6),"/",$E(ACHSEOBR("A",11),7,8),"/",$E(ACHSEOBR("A",11),1,4)
;
W !!!,"PURCHASE ORDER NO: ",$G(ACHSEOBR("A",12))
W ?34,"CONTROL NO.: ",$G(ACHSEOBR("A",13)),"-",$G(ACHSEOBR("A",5))
B ;
W !!,"AUTHORIZING FAC..: ",$G(ACHSEOBR("A",14))
W ?34,"PATIENT NAM: ",$G(ACHSEOBR("B",8)),!
I $O(^AUTTLOC("C",ACHSEOBR("A",14),0)) W ?19,"(",$P(^AUTTLOC($O(^AUTTLOC("C",ACHSEOBR("A",14),0)),0),U,2),")"
;
W !,"DOCUMENT TYPE....: ",$G(ACHSEOBR("A",15))
W ?34,"HLTH REC NO: ",$G(ACHSEOBR("B",9))
;
W !!,"AUTH. DATE.......: ",$$FMTE^XLFDT($G(ACHSEOBR("B",10))-17000000)
W ?34,"ACTUAL DAYS:",?47,$G(ACHSEOBR("B",11))
;
;D RTRN^ACHS
;I $G(ACHSQUIT) D END Q
I IO=IO(0) D RTRN^ACHS I $G(ACHSQUIT) D END Q ;ACHS*3.1*21
C ;
W !!,"COMMON ACCTG NO..: ",$E($G(ACHSEOBR("C",8)),1,7)
W ?34,"DRG........: ",$E($G(ACHSEOBR("C",8)),1,7)
; W ?47,"RATE QUOTE:" ; RQ is currently indicated with an "R" in the Contract number for those areas using RQ. GTH 05-22-97
;
W !,"INTEREST CAN.....: ",$G(ACHSEOBR("I",8))
W ?34,"DIS. STATUS: ",$G(ACHSEOBR("B",13))
W !!,"OBJECT CLASS CODE: ",$G(ACHSEOBR("C",9))
W ?34,"SERV BILLED:"
S X=$G(ACHSEOBR("C",10))
W ?47,$S(X="A":"PROFESSIONAL",X="B":"INPATIENT",X="C":"OUTPAT",X="D":"DENTAL",X="E":"ANCILLARY",X="F":"NON-PATIENT SPECIFIC",1:"UNKNOWN")
W !,"SERVICE CLASS CODE: ",$G(ACHSEOBR("B",14))
W ?34,"INTERST OCC: ",$G(ACHSEOBR("I",9))
W !!,"BLANKET IND......: ",$S($G(ACHSEOBR("C",11))="Y":"YES",$G(ACHSEOBR("C",11))="N":"NO",1:"??")
W ?34,"CONTRACT NO: ",$G(ACHSEOBR("C",12))
W !!,"INTERIM/FINAL IND: ",$S($G(ACHSEOBR("C",13))="F":"FINAL",$G(ACHSEOBR("C",13))="I":"INTERIM",1:"??")
W ?34,"VENDOR NO..: ",$G(ACHSEOBR("C",16))
D ;
W !!,"EST SERV DATES...: "
I +$G(ACHSEOBR("C",14)) W $E(ACHSEOBR("C",14),5,6),"/",$E(ACHSEOBR("C",14),7,8),"/",$E(ACHSEOBR("C",14),1,4)
;
W ?34,"VENDOR NAME: ",$E($G(ACHSEOBR("D",8)),1,30),!
;
I +$G(ACHSEOBR("C",15)) W ?19,$E(ACHSEOBR("C",15),5,6),"/",$E(ACHSEOBR("C",15),7,8),"/",$E(ACHSEOBR("C",15),1,4)
;
W !,"INTEREST RATE.(%): "
S X=$G(ACHSEOBR("I",10))
I X W $FN($E(X,1,2)_"."_$E(X,3,5),"",3)
;
W !,"DAYS ELIGIBLE....: "
W:+$G(ACHSEOBR("I",11)) ACHSEOBR("I",11)
;
;D RTRN^ACHS
;G END:$G(ACHSQUIT)
I IO=IO(0) D RTRN^ACHS G END:$G(ACHSQUIT) ;ACHS*3.1*21
;
S X=$G(ACHSEOBR("D",9))
D FMT
W !!!?19,"BILLED BY PROVIDER..........$",$G(X)
S X=$G(ACHSEOBR("D",10))
D FMT
W !?19,"ALLOWABLE AMOUNT............$",$G(X)
S X=$G(ACHSEOBR("D",11))
D FMT
W !?19,"AMOUNT PAID BY THIRD PARTY..$",$G(X)
E ;
;ACHS*3.1*23 CHANGED ALL "E" TO ACHSREJ
S X=$G(ACHSEOBR(ACHSREJ,8))
D FMT
W !?19,"FI PRINCIPLE PAYMENT........$",$G(X)
S X=$G(ACHSEOBR(ACHSREJ,10))
D FMT
W !?19,$S($G(ACHSEOBR(ACHSREJ,9))=1:"P.O.NBR",$G(ACHSEOBR(ACHSREJ,9))=2:"SHR 424",1:"???????")," OBLIGATION AMOUNT...$",$G(X)
;
S X=$G(ACHSEOBR("I",12))
D FMT
W !?19,"INTEREST PAID...............$",$G(X)
;
S X=$G(ACHSEOBR("I",13))
D FMT
W !?19,"ADDITIONAL PENALTY PAID.....$",$G(X)
;
S X=$G(ACHSEOBR("I",14))
D FMT
W !?19,"TOTAL PAID THIS TRANSACTION.$",$G(X)
;
;D RTRN^ACHS
;I $G(ACHSQUIT) D END Q
I IO=IO(0) D RTRN^ACHS I $G(ACHSQUIT) D END Q ;ACHS*3.1*21
;
W !!,"DIAGNOSIS CODES: "
;F ACHS=12:1:16 W " ",$G(ACHSEOBR("E",ACHS))
F ACHS=12:1 Q:'$D(ACHSEOBR(ACHSREJ,ACHS)) W $G(ACHSEOBR(ACHSREJ,ACHS))," " W:ACHS#8=0 ! ;ACHS*3.1*23
;ACHS*3.1*23 END OF CHANGE E TO ACHSREJ
;
W !,"PROCEDURE CODES:"
I $D(ACHSEOBR("G")) F ACHS=8:1:12 W " ",$G(ACHSEOBR("G",ACHS)) ;ACHS*3.1*23 ADDED 2 CODES
;
;GET THE F ARRAY FIELDS FROM TMP GLOBAL ;WHY DOES HE DO THIS?????
F ;
D FHDR
F1 ;
S ACHS=0
F S ACHS=$O(^TMP("ACHSEOB",$J,"F",ACHS)) Q:+ACHS=0 D
.S ACHSX=$G(^TMP("ACHSEOB",$J,"F",ACHS))
.I IO'=IO(0),$Y>(IOSL-8) D HDR,FHDR
.K ACHSTEMP D REC2^ACHSEOBB(ACHSX,.ACHSTEMP)
.W !,$E($G(ACHSTEMP("F",8)),5,6),"/",$E($G(ACHSTEMP("F",8)),7,8),"/"
.W $E($G(ACHSTEMP("F",8)),3,4)," "
.W $E($G(ACHSTEMP("F",9)),5,6),"/",$E($G(ACHSTEMP("F",9)),7,8),"/"
.W $E($G(ACHSTEMP("F",9)),3,4)
.S X="",ACHSZ=$G(ACHSTEMP("F",10))
.F I=1:1:5 I $E(ACHSZ,I,I)'=" " S X=X_$E(ACHSZ,I,I)
.W ?20,$J(X,5),?31,$G(ACHSTEMP("F",11)),?37,"$"
.;S X=$E(ACHSX,43,51)
.S X=$G(ACHSTEMP("F",12))
.D FMT
.W X,?51,"$"
.;S X=$E(ACHSX,52,60)
.S X=$G(ACHSTEMP("F",13))
.D FMT
.W X,?65,$G(ACHSTEMP("F",14)),?72,$G(ACHSTEMP("F",15))," ",$G(ACHSTEMP("F",16))
Q
;
G ;
N DIWL,DIWR,DIWF
S DIWL=7,DIWR=79,DIWF="W"
W !
S ACHSMSG=""
F S ACHSMSG=$O(ACHSEOBR("M","B",ACHSMSG)) Q:ACHSMSG="" W !,ACHSMSG," -" D GW
;D RTRN^ACHS
I IO=IO(0) D RTRN^ACHS ;ACHS*3.1*21
;
END ;
I IO'=IO(0) D HOME^%ZIS ;ACHS*3.1*21
I $P($P(^%ZIS(2,IOST(0),0),U,1),"-",1)="P",($D(^%ZIS(2,IOST(0),5))),$L($P(^(5),U,2)),$L($P(^(5),U,1)) W @($P(^%ZIS(2,IOST(0),5),U,1)) S IOM=80
K ACHSEOBR("M")
Q
;
GW ;
S ACHSMSGN="MESSAGE NOT ON FILE"
S ACHSZ="",ACHSZ=$O(^ACHSEOBM("B",ACHSMSG,ACHSZ))
I 'ACHSZ W ?6,ACHSMSGN Q
GWA ;
S ACHSY=0
F S ACHSY=$O(^ACHSEOBM(ACHSZ,1,ACHSY)) Q:+ACHSY=0 D
.S X=$$SB^ACHS($$RPL^ACHS(^ACHSEOBM(ACHSZ,1,ACHSY,0)," "," "))
.D ^DIWP
.I IO'=IO(0),$Y>(IOSL-8) D HDR
D ^DIWW
Q
;
FMT ;
I X["*" S X=" *********" Q
I X'["." S X=$E(X,1,$L(X)-2)_"."_$E(X,$L(X)-1,$L(X))
S X=$J($FN(X,",P",2),11)
Q
;
HDR ;
W !!?32,"+++ Continued +++",@IOF,!!?16,"+++ EOBR FOR PURCHASE ORDER NO '",ACHSEOBR("A",12),"' +++",!?32,"+++ Continued +++",!,ACHSTIME,!!
Q
;
FHDR ;
W ?72,"TOOTH",!,"DATES OF SERVICE PROCEDURE UNITS BILLED CHGS ALLOWABLE MSG NBR SURF",!,"----------------- --------- ----- ------------ ------------ ---- --------"
Q
;
ACHSEOB2 ; IHS/ITSC/TPF/PMF - PROCESS EOBRS (3/6) - PRINT EOBR ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**21,23**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*23 CHANGED E RECORD TO TEST FOR E OR J AND USE VAR ACHSREJ
+3 ;
+4 ;ACHS*3.1*21
IF ACHSEOIO'=IO
SET IOP=ACHSEOIO
DO ^%ZIS
+5 ;ACHS*3.1*23
SET ACHSREJ=$SELECT($DATA(ACHSEOBR("E")):"E",$DATA(ACHSEOBR("J")):"J",1:"")
+6 USE ACHSEOIO
+7 WRITE @IOF
+8 IF $PIECE($PIECE(^%ZIS(2,IOST(0),0),U,1),"-",1)="P"
IF ($DATA(^%ZIS(2,IOST(0),5)))
IF $LENGTH($PIECE(^(5),U,2))
IF $LENGTH($PIECE(^(5),U,1))
WRITE @($PIECE(^%ZIS(2,IOST(0),5),U,2))
SET IOM=90
+9 WRITE !!?20,"+++ EXPLANATION OF BENEFITS REPORT +++",!,ACHSTIME
+10 WRITE !?5,"INDIAN HEALTH SERVICE",?47,"CONTRACT HEALTH SERVICES",!
+11 ;
+12 ;CLAIM SEQUENCE COUNT
IF +ACHSEOBR("A",8)
WRITE ?62,"CLAIM SEQ. COUNT ",$JUSTIFY(+$GET(ACHSEOBR("A",8)),9)
A ;
+1 WRITE !!,"AREA OFFICE: ",$EXTRACT($PIECE(^AUTTAREA($ORDER(^AUTTAREA("C",ACHSEOBR("A",1),0)),0),U),1,17)
+2 WRITE ?34,"CHECK NUMB.: ",$GET(ACHSEOBR("A",9))
+3 WRITE !!,"SERVICE UNIT: ",$EXTRACT($PIECE(^AUTTSU($ORDER(^AUTTSU("C",ACHSEOBR("A",1)_ACHSEOBR("A",2),0)),0),U),1,17)
+4 ;
+5 ; Labels begin in col 1 and 35.
+6 ; Begin print info in col 20 and 48.
+7 ;
+8 WRITE ?34,"REMITTANCE.: ",$GET(ACHSEOBR("A",10))
+9 WRITE ?64,"DATE: ",$EXTRACT(ACHSEOBR("A",11),5,6),"/",$EXTRACT(ACHSEOBR("A",11),7,8),"/",$EXTRACT(ACHSEOBR("A",11),1,4)
+10 ;
+11 WRITE !!!,"PURCHASE ORDER NO: ",$GET(ACHSEOBR("A",12))
+12 WRITE ?34,"CONTROL NO.: ",$GET(ACHSEOBR("A",13)),"-",$GET(ACHSEOBR("A",5))
B ;
+1 WRITE !!,"AUTHORIZING FAC..: ",$GET(ACHSEOBR("A",14))
+2 WRITE ?34,"PATIENT NAM: ",$GET(ACHSEOBR("B",8)),!
+3 IF $ORDER(^AUTTLOC("C",ACHSEOBR("A",14),0))
WRITE ?19,"(",$PIECE(^AUTTLOC($ORDER(^AUTTLOC("C",ACHSEOBR("A",14),0)),0),U,2),")"
+4 ;
+5 WRITE !,"DOCUMENT TYPE....: ",$GET(ACHSEOBR("A",15))
+6 WRITE ?34,"HLTH REC NO: ",$GET(ACHSEOBR("B",9))
+7 ;
+8 WRITE !!,"AUTH. DATE.......: ",$$FMTE^XLFDT($GET(ACHSEOBR("B",10))-17000000)
+9 WRITE ?34,"ACTUAL DAYS:",?47,$GET(ACHSEOBR("B",11))
+10 ;
+11 ;D RTRN^ACHS
+12 ;I $G(ACHSQUIT) D END Q
+13 ;ACHS*3.1*21
IF IO=IO(0)
DO RTRN^ACHS
IF $GET(ACHSQUIT)
DO END
QUIT
C ;
+1 WRITE !!,"COMMON ACCTG NO..: ",$EXTRACT($GET(ACHSEOBR("C",8)),1,7)
+2 WRITE ?34,"DRG........: ",$EXTRACT($GET(ACHSEOBR("C",8)),1,7)
+3 ; W ?47,"RATE QUOTE:" ; RQ is currently indicated with an "R" in the Contract number for those areas using RQ. GTH 05-22-97
+4 ;
+5 WRITE !,"INTEREST CAN.....: ",$GET(ACHSEOBR("I",8))
+6 WRITE ?34,"DIS. STATUS: ",$GET(ACHSEOBR("B",13))
+7 WRITE !!,"OBJECT CLASS CODE: ",$GET(ACHSEOBR("C",9))
+8 WRITE ?34,"SERV BILLED:"
+9 SET X=$GET(ACHSEOBR("C",10))
+10 WRITE ?47,$SELECT(X="A":"PROFESSIONAL",X="B":"INPATIENT",X="C":"OUTPAT",X="D":"DENTAL",X="E":"ANCILLARY",X="F":"NON-PATIENT SPECIFIC",1:"UNKNOWN")
+11 WRITE !,"SERVICE CLASS CODE: ",$GET(ACHSEOBR("B",14))
+12 WRITE ?34,"INTERST OCC: ",$GET(ACHSEOBR("I",9))
+13 WRITE !!,"BLANKET IND......: ",$SELECT($GET(ACHSEOBR("C",11))="Y":"YES",$GET(ACHSEOBR("C",11))="N":"NO",1:"??")
+14 WRITE ?34,"CONTRACT NO: ",$GET(ACHSEOBR("C",12))
+15 WRITE !!,"INTERIM/FINAL IND: ",$SELECT($GET(ACHSEOBR("C",13))="F":"FINAL",$GET(ACHSEOBR("C",13))="I":"INTERIM",1:"??")
+16 WRITE ?34,"VENDOR NO..: ",$GET(ACHSEOBR("C",16))
D ;
+1 WRITE !!,"EST SERV DATES...: "
+2 IF +$GET(ACHSEOBR("C",14))
WRITE $EXTRACT(ACHSEOBR("C",14),5,6),"/",$EXTRACT(ACHSEOBR("C",14),7,8),"/",$EXTRACT(ACHSEOBR("C",14),1,4)
+3 ;
+4 WRITE ?34,"VENDOR NAME: ",$EXTRACT($GET(ACHSEOBR("D",8)),1,30),!
+5 ;
+6 IF +$GET(ACHSEOBR("C",15))
WRITE ?19,$EXTRACT(ACHSEOBR("C",15),5,6),"/",$EXTRACT(ACHSEOBR("C",15),7,8),"/",$EXTRACT(ACHSEOBR("C",15),1,4)
+7 ;
+8 WRITE !,"INTEREST RATE.(%): "
+9 SET X=$GET(ACHSEOBR("I",10))
+10 IF X
WRITE $FNUMBER($EXTRACT(X,1,2)_"."_$EXTRACT(X,3,5),"",3)
+11 ;
+12 WRITE !,"DAYS ELIGIBLE....: "
+13 IF +$GET(ACHSEOBR("I",11))
WRITE ACHSEOBR("I",11)
+14 ;
+15 ;D RTRN^ACHS
+16 ;G END:$G(ACHSQUIT)
+17 ;ACHS*3.1*21
IF IO=IO(0)
DO RTRN^ACHS
IF $GET(ACHSQUIT)
GOTO END
+18 ;
+19 SET X=$GET(ACHSEOBR("D",9))
+20 DO FMT
+21 WRITE !!!?19,"BILLED BY PROVIDER..........$",$GET(X)
+22 SET X=$GET(ACHSEOBR("D",10))
+23 DO FMT
+24 WRITE !?19,"ALLOWABLE AMOUNT............$",$GET(X)
+25 SET X=$GET(ACHSEOBR("D",11))
+26 DO FMT
+27 WRITE !?19,"AMOUNT PAID BY THIRD PARTY..$",$GET(X)
E ;
+1 ;ACHS*3.1*23 CHANGED ALL "E" TO ACHSREJ
+2 SET X=$GET(ACHSEOBR(ACHSREJ,8))
+3 DO FMT
+4 WRITE !?19,"FI PRINCIPLE PAYMENT........$",$GET(X)
+5 SET X=$GET(ACHSEOBR(ACHSREJ,10))
+6 DO FMT
+7 WRITE !?19,$SELECT($GET(ACHSEOBR(ACHSREJ,9))=1:"P.O.NBR",$GET(ACHSEOBR(ACHSREJ,9))=2:"SHR 424",1:"???????")," OBLIGATION AMOUNT...$",$GET(X)
+8 ;
+9 SET X=$GET(ACHSEOBR("I",12))
+10 DO FMT
+11 WRITE !?19,"INTEREST PAID...............$",$GET(X)
+12 ;
+13 SET X=$GET(ACHSEOBR("I",13))
+14 DO FMT
+15 WRITE !?19,"ADDITIONAL PENALTY PAID.....$",$GET(X)
+16 ;
+17 SET X=$GET(ACHSEOBR("I",14))
+18 DO FMT
+19 WRITE !?19,"TOTAL PAID THIS TRANSACTION.$",$GET(X)
+20 ;
+21 ;D RTRN^ACHS
+22 ;I $G(ACHSQUIT) D END Q
+23 ;ACHS*3.1*21
IF IO=IO(0)
DO RTRN^ACHS
IF $GET(ACHSQUIT)
DO END
QUIT
+24 ;
+25 WRITE !!,"DIAGNOSIS CODES: "
+26 ;F ACHS=12:1:16 W " ",$G(ACHSEOBR("E",ACHS))
+27 ;ACHS*3.1*23
FOR ACHS=12:1
IF '$DATA(ACHSEOBR(ACHSREJ,ACHS))
QUIT
WRITE $GET(ACHSEOBR(ACHSREJ,ACHS))," "
IF ACHS#8=0
WRITE !
+28 ;ACHS*3.1*23 END OF CHANGE E TO ACHSREJ
+29 ;
+30 WRITE !,"PROCEDURE CODES:"
+31 ;ACHS*3.1*23 ADDED 2 CODES
IF $DATA(ACHSEOBR("G"))
FOR ACHS=8:1:12
WRITE " ",$GET(ACHSEOBR("G",ACHS))
+32 ;
+33 ;GET THE F ARRAY FIELDS FROM TMP GLOBAL ;WHY DOES HE DO THIS?????
F ;
+1 DO FHDR
F1 ;
+1 SET ACHS=0
+2 FOR
SET ACHS=$ORDER(^TMP("ACHSEOB",$JOB,"F",ACHS))
IF +ACHS=0
QUIT
Begin DoDot:1
+3 SET ACHSX=$GET(^TMP("ACHSEOB",$JOB,"F",ACHS))
+4 IF IO'=IO(0)
IF $Y>(IOSL-8)
DO HDR
DO FHDR
+5 KILL ACHSTEMP
DO REC2^ACHSEOBB(ACHSX,.ACHSTEMP)
+6 WRITE !,$EXTRACT($GET(ACHSTEMP("F",8)),5,6),"/",$EXTRACT($GET(ACHSTEMP("F",8)),7,8),"/"
+7 WRITE $EXTRACT($GET(ACHSTEMP("F",8)),3,4)," "
+8 WRITE $EXTRACT($GET(ACHSTEMP("F",9)),5,6),"/",$EXTRACT($GET(ACHSTEMP("F",9)),7,8),"/"
+9 WRITE $EXTRACT($GET(ACHSTEMP("F",9)),3,4)
+10 SET X=""
SET ACHSZ=$GET(ACHSTEMP("F",10))
+11 FOR I=1:1:5
IF $EXTRACT(ACHSZ,I,I)'=" "
SET X=X_$EXTRACT(ACHSZ,I,I)
+12 WRITE ?20,$JUSTIFY(X,5),?31,$GET(ACHSTEMP("F",11)),?37,"$"
+13 ;S X=$E(ACHSX,43,51)
+14 SET X=$GET(ACHSTEMP("F",12))
+15 DO FMT
+16 WRITE X,?51,"$"
+17 ;S X=$E(ACHSX,52,60)
+18 SET X=$GET(ACHSTEMP("F",13))
+19 DO FMT
+20 WRITE X,?65,$GET(ACHSTEMP("F",14)),?72,$GET(ACHSTEMP("F",15))," ",$GET(ACHSTEMP("F",16))
End DoDot:1
+21 QUIT
+22 ;
G ;
+1 NEW DIWL,DIWR,DIWF
+2 SET DIWL=7
SET DIWR=79
SET DIWF="W"
+3 WRITE !
+4 SET ACHSMSG=""
+5 FOR
SET ACHSMSG=$ORDER(ACHSEOBR("M","B",ACHSMSG))
IF ACHSMSG=""
QUIT
WRITE !,ACHSMSG," -"
DO GW
+6 ;D RTRN^ACHS
+7 ;ACHS*3.1*21
IF IO=IO(0)
DO RTRN^ACHS
+8 ;
END ;
+1 ;ACHS*3.1*21
IF IO'=IO(0)
DO HOME^%ZIS
+2 IF $PIECE($PIECE(^%ZIS(2,IOST(0),0),U,1),"-",1)="P"
IF ($DATA(^%ZIS(2,IOST(0),5)))
IF $LENGTH($PIECE(^(5),U,2))
IF $LENGTH($PIECE(^(5),U,1))
WRITE @($PIECE(^%ZIS(2,IOST(0),5),U,1))
SET IOM=80
+3 KILL ACHSEOBR("M")
+4 QUIT
+5 ;
GW ;
+1 SET ACHSMSGN="MESSAGE NOT ON FILE"
+2 SET ACHSZ=""
SET ACHSZ=$ORDER(^ACHSEOBM("B",ACHSMSG,ACHSZ))
+3 IF 'ACHSZ
WRITE ?6,ACHSMSGN
QUIT
GWA ;
+1 SET ACHSY=0
+2 FOR
SET ACHSY=$ORDER(^ACHSEOBM(ACHSZ,1,ACHSY))
IF +ACHSY=0
QUIT
Begin DoDot:1
+3 SET X=$$SB^ACHS($$RPL^ACHS(^ACHSEOBM(ACHSZ,1,ACHSY,0)," "," "))
+4 DO ^DIWP
+5 IF IO'=IO(0)
IF $Y>(IOSL-8)
DO HDR
End DoDot:1
+6 DO ^DIWW
+7 QUIT
+8 ;
FMT ;
+1 IF X["*"
SET X=" *********"
QUIT
+2 IF X'["."
SET X=$EXTRACT(X,1,$LENGTH(X)-2)_"."_$EXTRACT(X,$LENGTH(X)-1,$LENGTH(X))
+3 SET X=$JUSTIFY($FNUMBER(X,",P",2),11)
+4 QUIT
+5 ;
HDR ;
+1 WRITE !!?32,"+++ Continued +++",@IOF,!!?16,"+++ EOBR FOR PURCHASE ORDER NO '",ACHSEOBR("A",12),"' +++",!?32,"+++ Continued +++",!,ACHSTIME,!!
+2 QUIT
+3 ;
FHDR ;
+1 WRITE ?72,"TOOTH",!,"DATES OF SERVICE PROCEDURE UNITS BILLED CHGS ALLOWABLE MSG NBR SURF",!,"----------------- --------- ----- ------------ ------------ ---- --------"
+2 QUIT
+3 ;
