ACHSMD0 ; IHS/ITSC/PMF - PRINT MASTER DELIVERY ORDER LIST (1/2) ; [ 02/19/2004 10:38 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,8**;JUNE 11, 2001
;
; IHS/ASDST/GTH 09/08/99 Modified at the request of the Navajo Area
; CHS officer to accommodate the 2-line MDOL report.
;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP AND ADDED
; SORT FOR DOS
;ACHS*3.1*6 6/19/03 IHS/SET/FCJ ADDED REQUEST TO PRINT BY ISSUE DATE
; MODIFICATION THROUGH OUT ROUTINE AND ADDED NEW SECTIONS
; AND SORTS
;ACHS*3.1*8 2/14/04 ITSC/SET/JVK REMOVE QUIT
;
A0 ;
I '$D(^ACHSF(DUZ(2),18,"B")) W !!,*7,?5,"No High Volume Providers for this Facility" D RTRN^ACHS G CANREQ
I '$D(^ACHSF(DUZ(2),"ES")) W !!,*7,?5,"No MDOL Documents (Orders) Have been entered." D RTRN^ACHS G CANREQ
S (ACHSPGNO,ACHSLC,ACHSPTOT,ACHSGTOT,ACHSTFLG,ACHSPNOT,ACHSGNOT)=0
;
A2 ; Select HVP.
S Y=$$HVP
G CANREQ:$D(DUOUT)!$D(DTOUT)
I +Y<1 W !!,*7,"No Vendor Selected" G CANREQ
S ACHSVPTR=+$P(Y,U),ACHSHVAB=$P(Y,U,2)
W !!
SEL W !!?20,"1) Print Report by Date of Service"
W !?20,"2) Print Report by Date of Issue"
S ACHSRPT=$$DIR^ACHS("N^1:2:0","Select",1,"","^D QSEL^ACHSDNS",2)
G:ACHSRPT'?1N.2N EXIT
;
A3 ; Select report date.
I ACHSRPT=1 D
.D HELP(8,ACHSVPTR)
.S (ACHSRDAT,ACHSEDAT)=$$DIR^XBDIR("D^::E","Enter Beginning MDOL By Date Service","","","2 ""??"" for list of dates","^D HELP^ACHSMD0(99)",1)
I ACHSRPT=2 D
.D HELP2(8,ACHSVPTR)
.S (ACHSRDAT,ACHSEDAT)=$$DIR^XBDIR("D^::E","Enter Beginning MDOL By Date of Issue","","","2 ""??"" for list of dates","^D HELP2^ACHSMD0(99)",1)
G CANREQ:$D(DTOUT)!$D(DUOUT)!'ACHSRDAT
I ACHSRPT=1,'$D(^ACHSF(DUZ(2),"ES",ACHSRDAT)) W !!,*7,?5,"No Documents (Orders) Available to Print on ",$$FMTE^XLFDT(ACHSRDAT) G A3
I ACHSRPT=1 S ACHSEDAT=$$DIR^XBDIR("D^::E","Enter Ending MDOL Date",$$FMTE^XLFDT(ACHSEDAT),"","2 ""??"" for list of dates","^D HELP^ACHSMD0(99)",1)
I ACHSRPT=2 S ACHSEDAT=$$DIR^XBDIR("D^::E","Enter Ending MDOL Date",$$FMTE^XLFDT(ACHSEDAT),"","2 ""??"" for list of dates","^D HELP2^ACHSMD0(99)",1)
G CANREQ:$D(DTOUT)!$D(DUOUT)!'ACHSEDAT
I $$EBB^ACHS(ACHSRDAT,ACHSEDAT) G A3
S ACHSJDAT=$E(ACHSRDAT,2,3)_$$JDT^ACHS(ACHSRDAT,1)
;
A2A ; Generate transmission file Y/N.
S ACHSTXF=$$DIR^XBDIR("Y","Do you want generate a TX FILE for this REPORT ","N","","","",1)
I $D(DUOUT)!($D(DTOUT)) G A3
I 'ACHSTXF G A7
I '$L($$AOP^ACHS(2,1)) D NODIR G CANREQ
S X="achsm0"_ACHSHVAB_"."_ACHSJDAT
I '$D(^AFSTXLOG(DUZ(2),1,"B",X)) G A5
I '$$DIR^XBDIR("Y","A TX FILE Already Exists for this Date - Continue (Y/N) ","","","","",1) G A2A
I $D(DUOUT)!($D(DTOUT)) G A2A
;
A5 ; Open file.
S ACHSZFN="achsm0"_ACHSHVAB,ACHSZOPT=1,ACHSZDIR=$$AOP^ACHS(2,1)
D ARCHLIST^ACHSARCH
S ACHSZFN=$$AOP^ACHS(2,1)_"achsm0"_ACHSHVAB_"."_ACHSJDAT
I $$DEL^%ZISH($$AOP^ACHS(2,1),"achsm0"_ACHSHVAB_"."_ACHSJDAT)
S ACHSZIN=0
D OPENHFS^ACHSTCK1
I ACHSZZA D ERROR^ACHSTCK1 G CANREQ
S ACHSHFS1=ACHSZDEV
A7 ; Select printer.
U IO(0)
W !
S %ZIS="P",%ZIS("A")="Enter Printer Output Device: "
D ^%ZIS
I POP G CANREQ
I IOM<132 W !!,*7,"Device Right Margin < 132 Char -- Select another Device" G A7
S ACHSRDT=$$HTE^XLFDT($H)
D CHK16^ACHSPS16
G A0:$D(DUOUT)
I '$D(ACHS("PRINT","ERROR")) G A8
G A0:$$DIR^XBDIR("E","","","","","",1)
G CANREQ
;
A8 ;
U IO(0)
W !!?10,"Your Request is now being Processed",!
I $D(ACHS("PRINT",16)) U IO W @ACHS("PRINT",16)
START ;
K ^TMP("ACHSMD0",$J)
S ACHSZR=ACHSRDAT-1
A9 ; $O thru Estimated Service dates.
I ACHSRPT=1 D G A15
.F S ACHSZR=$O(^ACHSF(DUZ(2),"ES",ACHSZR)) Q:ACHSZR=""!(ACHSZR>ACHSEDAT) D
..S ACHSDIEN=""
..F S ACHSDIEN=$O(^ACHSF(DUZ(2),"ES",ACHSZR,ACHSDIEN)) Q:ACHSDIEN="" D
...D A10
A9A ; $O thru Date of Issue.
I ACHSRPT=2 D G A15
.F S ACHSZR=$O(^ACHSF(DUZ(2),"TB",ACHSZR)) Q:ACHSZR=""!(ACHSZR>ACHSEDAT) D
..S ACHSTYP=""
..F S ACHSTYP=$O(^ACHSF(DUZ(2),"TB",ACHSZR,ACHSTYP)) Q:ACHSTYP="" D
...Q:ACHSTYP'="I"
...S ACHSDIEN=""
...F S ACHSDIEN=$O(^ACHSF(DUZ(2),"TB",ACHSZR,ACHSTYP,ACHSDIEN)) Q:ACHSDIEN="" D A10
A10 ; $O thru document IENs.
;S ACHSDIEN=$O(^ACHSF(DUZ(2),"ES",ACHSZR,ACHSDIEN))
;G A9:ACHSDIEN=""
S ACHSX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
Q:$P(ACHSX,U,12)=4 ; Skip canceled docs.
;ITSC/SET/JVK ACHS*3.1*8 2.19.04
;I +$P(ACHSX,U,4)=2 S ^TMP("ACHSMD0",$J,DUZ(2),"D",ACHSDIEN)="" Q
I +$P(ACHSX,U,4)=2 S ^TMP("ACHSMD0",$J,DUZ(2),"D",ACHSDIEN)=""
;ACHS*3.1*6 4/7/03 IHS/SET/FCJ SORT BY DOS
;S ^TMP("ACHSMD0",$J,DUZ(2),$P(ACHSX,U,17),ACHSDIEN)=""
S ^TMP("ACHSMD0",$J,DUZ(2),$P(ACHSX,U,17),ACHSZR,ACHSDIEN)=""
;G A10
Q
;
A15 ;
F ACHSRTYP="F","I","D" S (ACHSPGNO,ACHSPTOT,ACHSGTOT,ACHSPNOT,ACHSGNOT,ACHSLC)=0 D A18
I $D(ACHS("PRINT",16)) U IO D 10^ACHSPS16
D ^%ZISC
I 'ACHSTXF G EXIT
S IO=ACHSHFS1
D ^%ZISC
S ACHSEXFS="achsm0"_ACHSHVAB_"."_ACHSJDAT
D TXLOGADD^ACHSTXUT
G EXIT:ACHSY>0
U IO(0)
W *7,!,"Entry NOT Successfully Posted to Data Tranmission Log - Notify Supervisor",!
D RTRN^ACHS
G EXIT
;
CANREQ ;
U IO(0)
W !!?20,"Request Cancelled"
D RTRN^ACHS
EXIT ; Kill vars, quit.
K DIR,DIC,DFN
D EN^XBVK("ACHS"),^ACHSVAR
Q
;
HELP(Z,V) ;EP - From DIR. Z = Number of dates to display. V = Ptr to VENDOR.
N X,Y
S X=3991231,Y=0
W !!,"Recent MDOL by date of Service for ",$P(^AUTTVNDR(ACHSVPTR,0),U)," :"
F S X=$O(^ACHSF(DUZ(2),"ES",X),-1) Q:('X)!(Y=Z) D
.I $P(^ACHSF(DUZ(2),"D",$O(^ACHSF(DUZ(2),"ES",X,0)),0),U,8)=ACHSVPTR W !?20,$$FMTE^XLFDT(X) S Y=Y+1 Q:Y=Z I 'Y#10 D RTRN^ACHS Q:$G(ACHSQUIT) ; The reverse $ORDER lists as error to %INDEX.
K ACHSQUIT
Q
HELP2(Z,V) ;EP - From DIR. Z = Number of dates to display. V = Ptr to VENDOR.
N X,Y
S X=3991231,Y=0,ACHSTYP=0
W !!,"Recent MDOL by date of issue for ",$P(^AUTTVNDR(ACHSVPTR,0),U)," :"
F S X=$O(^ACHSF(DUZ(2),"TB",X),-1) Q:'X F S ACHSTYP=$O(^ACHSF(DUZ(2),"TB",X,ACHSTYP)) Q:(ACHSTYP'="I")!(Y=Z) D Q:Y=Z
.I $P(^ACHSF(DUZ(2),"D",$O(^ACHSF(DUZ(2),"TB",X,ACHSTYP,0)),0),U,8)=ACHSVPTR W !?20,$$FMTE^XLFDT(X) S Y=Y+1 Q:Y=Z I 'Y#10 D RTRN^ACHS Q:$G(ACHSQUIT) ; The reverse $ORDER lists as error to %INDEX.
K ACHSQUIT
Q
;
NODIR ;EP - Display missing parameter message.
U IO(0)
W *7,!,$$C^XBFUNC("Your EOBR IMPORT DIRECTORY is not defined in your")
W !,$$C^XBFUNC("CHS AREA OFFICE PARAMETERS file.")
W !,$$C^XBFUNC("The directory is usually"),!,$$C^XBFUNC("/usr/ihs/reports/"),!,$$C^XBFUNC("for unix systems, and"),!,$$C^XBFUNC("C:\IMPORT\"),!,$$C^XBFUNC("for DOS systems.")
W !!,$$C^XBFUNC("( The same directory is used for HVP files. )")
Q
;
HVP() ;EP - Select HVP.
K DUOUT,DTOUT
S DIC="^ACHSF("_DUZ(2)_",18,",DIC(0)="QAZEM"
D ^DIC
Q:$D(DUOUT)!$D(DTOUT)!(+Y<1) -1
Q Y(0)
;
;
; ACHSRTYP="D":"DENTAL SERVICES"
; ACHSRTYP="I":"AO PAYMENTS"
; ACHSRTYP="F":"FI PAYMENTS"
;
A18 ; -- Print MDOL, Dental, AO Payments, or FI Payments.
Q:'$D(^TMP("ACHSMD0",$J,DUZ(2),ACHSRTYP))
U IO
D SETHDR,HDR
I ACHSTXF=1 U ACHSHFS1 D HDR
S ACHSZR=ACHSRDAT,ACHSDIEN=""
B0 ; Loop thru work global.
;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP INSTEAD OF G
;S ACHSDIEN="" ;ACHS*3.1*6 4/7/03
B1 ;
;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP AND ADDED SORT FOR DOS
S ACHSDOS=""
F S ACHSDOS=$O(^TMP("ACHSMD0",$J,DUZ(2),ACHSRTYP,ACHSDOS)) G:ACHSDOS'?1N.N BEND D
.S ACHSDIEN=""
.F S ACHSDIEN=$O(^TMP("ACHSMD0",$J,DUZ(2),ACHSRTYP,ACHSDOS,ACHSDIEN)) Q:ACHSDIEN'?1N.N D
..S ACHSX=$G(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
..Q:$P(ACHSX,U,8)'=ACHSVPTR
..U IO
..D LINE
..S ACHSPTOT=ACHSPTOT+ACHSCOST,ACHSGTOT=ACHSGTOT+ACHSCOST
..I ACHSTXF U ACHSHFS1 D LINE
..S ACHSPNOT=ACHSPNOT+1,ACHSGNOT=ACHSGNOT+1,ACHSLC=ACHSLC+1
..I ACHSLC#45=0 U IO D FTR1,FTR1A,RTRN^ACHS,SETHDR,HDR I ACHSTXF U ACHSHFS1 D FTR1,FTR1A,HDR
;
LINE ;
I $P(ACHSX,U,3) W $S($P(ACHSX,U,3)=1:"** BLANKET **",1:"** SPEC TRAN **") G DOS
;
W $J($P(ACHSX,U,21),6) ; HRN
;
S Y=$P(ACHSX,U,22)
D ^AUPNPAT
;
W ?7,$E($P(^DPT(DFN,0),U),1,28) ; Name
;
W ?34,$E(DOB,4,7),$E(DOB,1,3)+1700 ; DOB
;
W ?43,SEX ; Sex
;
W ?45,$P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U,2) ; Tribe code
;
W ?49,SSN ; SSN
;
S (X,%)=0
; Community, County, State
F S X=$O(^AUPNPAT(DFN,51,X)) Q:X="" S %=X
I %,$P(^AUPNPAT(DFN,51,%,0),U,3) S %=$P(^AUTTCOM($P(^AUPNPAT(DFN,51,%,0),U,3),0),U,8) W ?59,$E(%,5,7),$E(%,3,4),$E(%,1,2)
;
DOS ; Date Of Service - MMDDYY
S %=$$DOC^ACHS(3,9),%=$E(%,4,7)_$E(%,2,3)
W ?67,%
;
; P.O. #
D FC^ACHSUF
W ?74,$P(ACHSX,U,14)_ACHSFC_"-"_$P(ACHSX,U)
;
; Estimated cost
S X=$P(ACHSX,U,9)
W ?85,$J(X,10,2)
S ACHSCOST=X
;
;
; Coverage (Insurance)
W ?96,"000"
;
; Account #
W ?100,$$DOC^ACHS(1,3)
;IHS/ITSC/PMF added the condition to the next line. Only
;do the other routine if this is NOT a blanket order
I '$P(ACHSX,U,3) D EN^ACHSMD0A($$DOC^ACHS(3,9))
W !
Q
;
BEND ;
U IO
D FTR1
I ACHSTXF=1 U ACHSHFS1 D FTR1
BENDA ;
S ACHSTFLG=ACHSTFLG+1
U IO
D FTR1,FTR1A
W !!
I ACHSTXF=1 U ACHSHFS1 D FTR1,FTR1A W !!
D RTRN^ACHS
Q
;
SETHDR ;
S ACHSPGNO=ACHSPGNO+1,ACHSPTOT=0,ACHSPNOT=0
Q
;
HDR ;
W @IOF,$$C^XBFUNC("MASTER DELIVERY ORDER LISTING FOR: "_$$LOC^ACHS,IOM),!
I ACHSRPT=1 W $$C^XBFUNC("BY DATE OF ESTIMATED SERVICE",IOM),!
I ACHSRPT=2 W $$C^XBFUNC("BY DATE OF ISSUE",IOM),!
S X="FOR PATIENTS TREATED BY: "_$P(^AUTTVNDR(ACHSVPTR,0),U)
W !?2,ACHSRDT,?IOM-$L(X)/2,X,?IOM-10,"Page ",ACHSPGNO
S X=$S(ACHSRTYP="I":"FOR AO PAYMENT FOR SERVICES PROVIDED : ",ACHSRTYP="F":"FOR FI PAYMENT FOR SERVICES PROVIDED : ",ACHSRTYP="D":"FOR DENTAL SERVICES PROVIDED : ",1:"DATE(S) OF SERVICE: ")
W !,$$C^XBFUNC(X_$$FMTE^XLFDT(ACHSRDAT)_" - "_$$FMTE^XLFDT(ACHSEDAT),IOM),!!
W "IHS #",?16,"PATIENT NAME",?38,"DOB",?43,"S",?45,"TRB",?49,"SOC SEC #",?59,"COMM-CD",?67,"ESTDOS",?74,"PURCH OR #",?85,"EST. COST",?96,"COV",?100,"ACCT NO",!
W $$R("-",6),?7,$$R("-",28),?36,$$R("-",6),?43,$$R("-",1),?45,$$R("-",3),?49,$$R("-",9),?59,$$R("-",7),?67,$$R("-",6),?74,$$R("-",10),?85,$$R("-",10),?96,$$R("-",3),?100,$$R("-",15),!
Q
;
FTR1 ;
I ACHSTFLG=0 W !?40,"NO. ITEMS (THIS PAGE): ",$J(ACHSPNOT,3),?69,"SUB-TOTAL(THIS PAGE):",?95,$J($FN(ACHSPTOT,",",2),15)
I ACHSTFLG>0 W !?7,"TOTAL PAGES IN REPORT: ",$J(ACHSPGNO,3),?40,"NO ITEMS (ALL PAGES):",$J(ACHSGNOT,5),?69,"GRAND TOTAL(ALL PAGES):",?95,$J($FN(ACHSGTOT,",",2),15)
Q
;
FTR1A ;
W !!," Date: ",$$R("_",13),?25,"Funds Available Signature:",?60,$$R("_",30),!!
W " Date: ",$$R("_",13),?25,"Ordering Official Signature:",?60,$$R("_",30),!!
W " Date: ",$$R("_",13),?25,"Vendor Services Received:",?60,$$R("_",30),!!
Q
;
R(X,Y) Q $$REPEAT^XLFSTR(X,Y)
;
ACHSMD0 ; IHS/ITSC/PMF - PRINT MASTER DELIVERY ORDER LIST (1/2) ; [ 02/19/2004 10:38 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**6,8**;JUNE 11, 2001
+2 ;
+3 ; IHS/ASDST/GTH 09/08/99 Modified at the request of the Navajo Area
+4 ; CHS officer to accommodate the 2-line MDOL report.
+5 ;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP AND ADDED
+6 ; SORT FOR DOS
+7 ;ACHS*3.1*6 6/19/03 IHS/SET/FCJ ADDED REQUEST TO PRINT BY ISSUE DATE
+8 ; MODIFICATION THROUGH OUT ROUTINE AND ADDED NEW SECTIONS
+9 ; AND SORTS
+10 ;ACHS*3.1*8 2/14/04 ITSC/SET/JVK REMOVE QUIT
+11 ;
A0 ;
+1 IF '$DATA(^ACHSF(DUZ(2),18,"B"))
WRITE !!,*7,?5,"No High Volume Providers for this Facility"
DO RTRN^ACHS
GOTO CANREQ
+2 IF '$DATA(^ACHSF(DUZ(2),"ES"))
WRITE !!,*7,?5,"No MDOL Documents (Orders) Have been entered."
DO RTRN^ACHS
GOTO CANREQ
+3 SET (ACHSPGNO,ACHSLC,ACHSPTOT,ACHSGTOT,ACHSTFLG,ACHSPNOT,ACHSGNOT)=0
+4 ;
A2 ; Select HVP.
+1 SET Y=$$HVP
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CANREQ
+3 IF +Y<1
WRITE !!,*7,"No Vendor Selected"
GOTO CANREQ
+4 SET ACHSVPTR=+$PIECE(Y,U)
SET ACHSHVAB=$PIECE(Y,U,2)
+5 WRITE !!
SEL WRITE !!?20,"1) Print Report by Date of Service"
+1 WRITE !?20,"2) Print Report by Date of Issue"
+2 SET ACHSRPT=$$DIR^ACHS("N^1:2:0","Select",1,"","^D QSEL^ACHSDNS",2)
+3 IF ACHSRPT'?1N.2N
GOTO EXIT
+4 ;
A3 ; Select report date.
+1 IF ACHSRPT=1
Begin DoDot:1
+2 DO HELP(8,ACHSVPTR)
+3 SET (ACHSRDAT,ACHSEDAT)=$$DIR^XBDIR("D^::E","Enter Beginning MDOL By Date Service","","","2 ""??"" for list of dates","^D HELP^ACHSMD0(99)",1)
End DoDot:1
+4 IF ACHSRPT=2
Begin DoDot:1
+5 DO HELP2(8,ACHSVPTR)
+6 SET (ACHSRDAT,ACHSEDAT)=$$DIR^XBDIR("D^::E","Enter Beginning MDOL By Date of Issue","","","2 ""??"" for list of dates","^D HELP2^ACHSMD0(99)",1)
End DoDot:1
+7 IF $DATA(DTOUT)!$DATA(DUOUT)!'ACHSRDAT
GOTO CANREQ
+8 IF ACHSRPT=1
IF '$DATA(^ACHSF(DUZ(2),"ES",ACHSRDAT))
WRITE !!,*7,?5,"No Documents (Orders) Available to Print on ",$$FMTE^XLFDT(ACHSRDAT)
GOTO A3
+9 IF ACHSRPT=1
SET ACHSEDAT=$$DIR^XBDIR("D^::E","Enter Ending MDOL Date",$$FMTE^XLFDT(ACHSEDAT),"","2 ""??"" for list of dates","^D HELP^ACHSMD0(99)",1)
+10 IF ACHSRPT=2
SET ACHSEDAT=$$DIR^XBDIR("D^::E","Enter Ending MDOL Date",$$FMTE^XLFDT(ACHSEDAT),"","2 ""??"" for list of dates","^D HELP2^ACHSMD0(99)",1)
+11 IF $DATA(DTOUT)!$DATA(DUOUT)!'ACHSEDAT
GOTO CANREQ
+12 IF $$EBB^ACHS(ACHSRDAT,ACHSEDAT)
GOTO A3
+13 SET ACHSJDAT=$EXTRACT(ACHSRDAT,2,3)_$$JDT^ACHS(ACHSRDAT,1)
+14 ;
A2A ; Generate transmission file Y/N.
+1 SET ACHSTXF=$$DIR^XBDIR("Y","Do you want generate a TX FILE for this REPORT ","N","","","",1)
+2 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO A3
+3 IF 'ACHSTXF
GOTO A7
+4 IF '$LENGTH($$AOP^ACHS(2,1))
DO NODIR
GOTO CANREQ
+5 SET X="achsm0"_ACHSHVAB_"."_ACHSJDAT
+6 IF '$DATA(^AFSTXLOG(DUZ(2),1,"B",X))
GOTO A5
+7 IF '$$DIR^XBDIR("Y","A TX FILE Already Exists for this Date - Continue (Y/N) ","","","","",1)
GOTO A2A
+8 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO A2A
+9 ;
A5 ; Open file.
+1 SET ACHSZFN="achsm0"_ACHSHVAB
SET ACHSZOPT=1
SET ACHSZDIR=$$AOP^ACHS(2,1)
+2 DO ARCHLIST^ACHSARCH
+3 SET ACHSZFN=$$AOP^ACHS(2,1)_"achsm0"_ACHSHVAB_"."_ACHSJDAT
+4 IF $$DEL^%ZISH($$AOP^ACHS(2,1),"achsm0"_ACHSHVAB_"."_ACHSJDAT)
+5 SET ACHSZIN=0
+6 DO OPENHFS^ACHSTCK1
+7 IF ACHSZZA
DO ERROR^ACHSTCK1
GOTO CANREQ
+8 SET ACHSHFS1=ACHSZDEV
A7 ; Select printer.
+1 USE IO(0)
+2 WRITE !
+3 SET %ZIS="P"
SET %ZIS("A")="Enter Printer Output Device: "
+4 DO ^%ZIS
+5 IF POP
GOTO CANREQ
+6 IF IOM<132
WRITE !!,*7,"Device Right Margin < 132 Char -- Select another Device"
GOTO A7
+7 SET ACHSRDT=$$HTE^XLFDT($HOROLOG)
+8 DO CHK16^ACHSPS16
+9 IF $DATA(DUOUT)
GOTO A0
+10 IF '$DATA(ACHS("PRINT","ERROR"))
GOTO A8
+11 IF $$DIR^XBDIR("E","","","","","",1)
GOTO A0
+12 GOTO CANREQ
+13 ;
A8 ;
+1 USE IO(0)
+2 WRITE !!?10,"Your Request is now being Processed",!
+3 IF $DATA(ACHS("PRINT",16))
USE IO
WRITE @ACHS("PRINT",16)
START ;
+1 KILL ^TMP("ACHSMD0",$JOB)
+2 SET ACHSZR=ACHSRDAT-1
A9 ; $O thru Estimated Service dates.
+1 IF ACHSRPT=1
Begin DoDot:1
+2 FOR
SET ACHSZR=$ORDER(^ACHSF(DUZ(2),"ES",ACHSZR))
IF ACHSZR=""!(ACHSZR>ACHSEDAT)
QUIT
Begin DoDot:2
+3 SET ACHSDIEN=""
+4 FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"ES",ACHSZR,ACHSDIEN))
IF ACHSDIEN=""
QUIT
Begin DoDot:3
+5 DO A10
End DoDot:3
End DoDot:2
End DoDot:1
GOTO A15
A9A ; $O thru Date of Issue.
+1 IF ACHSRPT=2
Begin DoDot:1
+2 FOR
SET ACHSZR=$ORDER(^ACHSF(DUZ(2),"TB",ACHSZR))
IF ACHSZR=""!(ACHSZR>ACHSEDAT)
QUIT
Begin DoDot:2
+3 SET ACHSTYP=""
+4 FOR
SET ACHSTYP=$ORDER(^ACHSF(DUZ(2),"TB",ACHSZR,ACHSTYP))
IF ACHSTYP=""
QUIT
Begin DoDot:3
+5 IF ACHSTYP'="I"
QUIT
+6 SET ACHSDIEN=""
+7 FOR
SET ACHSDIEN=$ORDER(^ACHSF(DUZ(2),"TB",ACHSZR,ACHSTYP,ACHSDIEN))
IF ACHSDIEN=""
QUIT
DO A10
End DoDot:3
End DoDot:2
End DoDot:1
GOTO A15
A10 ; $O thru document IENs.
+1 ;S ACHSDIEN=$O(^ACHSF(DUZ(2),"ES",ACHSZR,ACHSDIEN))
+2 ;G A9:ACHSDIEN=""
+3 SET ACHSX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
+4 ; Skip canceled docs.
IF $PIECE(ACHSX,U,12)=4
QUIT
+5 ;ITSC/SET/JVK ACHS*3.1*8 2.19.04
+6 ;I +$P(ACHSX,U,4)=2 S ^TMP("ACHSMD0",$J,DUZ(2),"D",ACHSDIEN)="" Q
+7 IF +$PIECE(ACHSX,U,4)=2
SET ^TMP("ACHSMD0",$JOB,DUZ(2),"D",ACHSDIEN)=""
+8 ;ACHS*3.1*6 4/7/03 IHS/SET/FCJ SORT BY DOS
+9 ;S ^TMP("ACHSMD0",$J,DUZ(2),$P(ACHSX,U,17),ACHSDIEN)=""
+10 SET ^TMP("ACHSMD0",$JOB,DUZ(2),$PIECE(ACHSX,U,17),ACHSZR,ACHSDIEN)=""
+11 ;G A10
+12 QUIT
+13 ;
A15 ;
+1 FOR ACHSRTYP="F","I","D"
SET (ACHSPGNO,ACHSPTOT,ACHSGTOT,ACHSPNOT,ACHSGNOT,ACHSLC)=0
DO A18
+2 IF $DATA(ACHS("PRINT",16))
USE IO
DO 10^ACHSPS16
+3 DO ^%ZISC
+4 IF 'ACHSTXF
GOTO EXIT
+5 SET IO=ACHSHFS1
+6 DO ^%ZISC
+7 SET ACHSEXFS="achsm0"_ACHSHVAB_"."_ACHSJDAT
+8 DO TXLOGADD^ACHSTXUT
+9 IF ACHSY>0
GOTO EXIT
+10 USE IO(0)
+11 WRITE *7,!,"Entry NOT Successfully Posted to Data Tranmission Log - Notify Supervisor",!
+12 DO RTRN^ACHS
+13 GOTO EXIT
+14 ;
CANREQ ;
+1 USE IO(0)
+2 WRITE !!?20,"Request Cancelled"
+3 DO RTRN^ACHS
EXIT ; Kill vars, quit.
+1 KILL DIR,DIC,DFN
+2 DO EN^XBVK("ACHS")
DO ^ACHSVAR
+3 QUIT
+4 ;
HELP(Z,V) ;EP - From DIR. Z = Number of dates to display. V = Ptr to VENDOR.
+1 NEW X,Y
+2 SET X=3991231
SET Y=0
+3 WRITE !!,"Recent MDOL by date of Service for ",$PIECE(^AUTTVNDR(ACHSVPTR,0),U)," :"
+4 FOR
SET X=$ORDER(^ACHSF(DUZ(2),"ES",X),-1)
IF ('X)!(Y=Z)
QUIT
Begin DoDot:1
+5 ; The reverse $ORDER lists as error to %INDEX.
IF $PIECE(^ACHSF(DUZ(2),"D",$ORDER(^ACHSF(DUZ(2),"ES",X,0)),0),U,8)=ACHSVPTR
WRITE !?20,$$FMTE^XLFDT(X)
SET Y=Y+1
IF Y=Z
QUIT
IF 'Y#10
DO RTRN^ACHS
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
+6 KILL ACHSQUIT
+7 QUIT
HELP2(Z,V) ;EP - From DIR. Z = Number of dates to display. V = Ptr to VENDOR.
+1 NEW X,Y
+2 SET X=3991231
SET Y=0
SET ACHSTYP=0
+3 WRITE !!,"Recent MDOL by date of issue for ",$PIECE(^AUTTVNDR(ACHSVPTR,0),U)," :"
+4 FOR
SET X=$ORDER(^ACHSF(DUZ(2),"TB",X),-1)
IF 'X
QUIT
FOR
SET ACHSTYP=$ORDER(^ACHSF(DUZ(2),"TB",X,ACHSTYP))
IF (ACHSTYP'="I")!(Y=Z)
QUIT
Begin DoDot:1
+5 ; The reverse $ORDER lists as error to %INDEX.
IF $PIECE(^ACHSF(DUZ(2),"D",$ORDER(^ACHSF(DUZ(2),"TB",X,ACHSTYP,0)),0),U,8)=ACHSVPTR
WRITE !?20,$$FMTE^XLFDT(X)
SET Y=Y+1
IF Y=Z
QUIT
IF 'Y#10
DO RTRN^ACHS
IF $GET(ACHSQUIT)
QUIT
End DoDot:1
IF Y=Z
QUIT
+6 KILL ACHSQUIT
+7 QUIT
+8 ;
NODIR ;EP - Display missing parameter message.
+1 USE IO(0)
+2 WRITE *7,!,$$C^XBFUNC("Your EOBR IMPORT DIRECTORY is not defined in your")
+3 WRITE !,$$C^XBFUNC("CHS AREA OFFICE PARAMETERS file.")
+4 WRITE !,$$C^XBFUNC("The directory is usually"),!,$$C^XBFUNC("/usr/ihs/reports/"),!,$$C^XBFUNC("for unix systems, and"),!,$$C^XBFUNC("C:\IMPORT\"),!,$$C^XBFUNC("for DOS systems.")
+5 WRITE !!,$$C^XBFUNC("( The same directory is used for HVP files. )")
+6 QUIT
+7 ;
HVP() ;EP - Select HVP.
+1 KILL DUOUT,DTOUT
+2 SET DIC="^ACHSF("_DUZ(2)_",18,"
SET DIC(0)="QAZEM"
+3 DO ^DIC
+4 IF $DATA(DUOUT)!$DATA(DTOUT)!(+Y<1)
QUIT -1
+5 QUIT Y(0)
+6 ;
+7 ;
+8 ; ACHSRTYP="D":"DENTAL SERVICES"
+9 ; ACHSRTYP="I":"AO PAYMENTS"
+10 ; ACHSRTYP="F":"FI PAYMENTS"
+11 ;
A18 ; -- Print MDOL, Dental, AO Payments, or FI Payments.
+1 IF '$DATA(^TMP("ACHSMD0",$JOB,DUZ(2),ACHSRTYP))
QUIT
+2 USE IO
+3 DO SETHDR
DO HDR
+4 IF ACHSTXF=1
USE ACHSHFS1
DO HDR
+5 SET ACHSZR=ACHSRDAT
SET ACHSDIEN=""
B0 ; Loop thru work global.
+1 ;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP INSTEAD OF G
+2 ;S ACHSDIEN="" ;ACHS*3.1*6 4/7/03
B1 ;
+1 ;ACHS*3.1*6 4/7/03 IHS/SET/FCJ CHANGED B1 TO A DO LOOP AND ADDED SORT FOR DOS
+2 SET ACHSDOS=""
+3 FOR
SET ACHSDOS=$ORDER(^TMP("ACHSMD0",$JOB,DUZ(2),ACHSRTYP,ACHSDOS))
IF ACHSDOS'?1N.N
GOTO BEND
Begin DoDot:1
+4 SET ACHSDIEN=""
+5 FOR
SET ACHSDIEN=$ORDER(^TMP("ACHSMD0",$JOB,DUZ(2),ACHSRTYP,ACHSDOS,ACHSDIEN))
IF ACHSDIEN'?1N.N
QUIT
Begin DoDot:2
+6 SET ACHSX=$GET(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
+7 IF $PIECE(ACHSX,U,8)'=ACHSVPTR
QUIT
+8 USE IO
+9 DO LINE
+10 SET ACHSPTOT=ACHSPTOT+ACHSCOST
SET ACHSGTOT=ACHSGTOT+ACHSCOST
+11 IF ACHSTXF
USE ACHSHFS1
DO LINE
+12 SET ACHSPNOT=ACHSPNOT+1
SET ACHSGNOT=ACHSGNOT+1
SET ACHSLC=ACHSLC+1
+13 IF ACHSLC#45=0
USE IO
DO FTR1
DO FTR1A
DO RTRN^ACHS
DO SETHDR
DO HDR
IF ACHSTXF
USE ACHSHFS1
DO FTR1
DO FTR1A
DO HDR
End DoDot:2
End DoDot:1
+14 ;
LINE ;
+1 IF $PIECE(ACHSX,U,3)
WRITE $SELECT($PIECE(ACHSX,U,3)=1:"** BLANKET **",1:"** SPEC TRAN **")
GOTO DOS
+2 ;
+3 ; HRN
WRITE $JUSTIFY($PIECE(ACHSX,U,21),6)
+4 ;
+5 SET Y=$PIECE(ACHSX,U,22)
+6 DO ^AUPNPAT
+7 ;
+8 ; Name
WRITE ?7,$EXTRACT($PIECE(^DPT(DFN,0),U),1,28)
+9 ;
+10 ; DOB
WRITE ?34,$EXTRACT(DOB,4,7),$EXTRACT(DOB,1,3)+1700
+11 ;
+12 ; Sex
WRITE ?43,SEX
+13 ;
+14 ; Tribe code
WRITE ?45,$PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U,2)
+15 ;
+16 ; SSN
WRITE ?49,SSN
+17 ;
+18 SET (X,%)=0
+19 ; Community, County, State
+20 FOR
SET X=$ORDER(^AUPNPAT(DFN,51,X))
IF X=""
QUIT
SET %=X
+21 IF %
IF $PIECE(^AUPNPAT(DFN,51,%,0),U,3)
SET %=$PIECE(^AUTTCOM($PIECE(^AUPNPAT(DFN,51,%,0),U,3),0),U,8)
WRITE ?59,$EXTRACT(%,5,7),$EXTRACT(%,3,4),$EXTRACT(%,1,2)
+22 ;
DOS ; Date Of Service - MMDDYY
+1 SET %=$$DOC^ACHS(3,9)
SET %=$EXTRACT(%,4,7)_$EXTRACT(%,2,3)
+2 WRITE ?67,%
+3 ;
+4 ; P.O. #
+5 DO FC^ACHSUF
+6 WRITE ?74,$PIECE(ACHSX,U,14)_ACHSFC_"-"_$PIECE(ACHSX,U)
+7 ;
+8 ; Estimated cost
+9 SET X=$PIECE(ACHSX,U,9)
+10 WRITE ?85,$JUSTIFY(X,10,2)
+11 SET ACHSCOST=X
+12 ;
+13 ;
+14 ; Coverage (Insurance)
+15 WRITE ?96,"000"
+16 ;
+17 ; Account #
+18 WRITE ?100,$$DOC^ACHS(1,3)
+19 ;IHS/ITSC/PMF added the condition to the next line. Only
+20 ;do the other routine if this is NOT a blanket order
+21 IF '$PIECE(ACHSX,U,3)
DO EN^ACHSMD0A($$DOC^ACHS(3,9))
+22 WRITE !
+23 QUIT
+24 ;
BEND ;
+1 USE IO
+2 DO FTR1
+3 IF ACHSTXF=1
USE ACHSHFS1
DO FTR1
BENDA ;
+1 SET ACHSTFLG=ACHSTFLG+1
+2 USE IO
+3 DO FTR1
DO FTR1A
+4 WRITE !!
+5 IF ACHSTXF=1
USE ACHSHFS1
DO FTR1
DO FTR1A
WRITE !!
+6 DO RTRN^ACHS
+7 QUIT
+8 ;
SETHDR ;
+1 SET ACHSPGNO=ACHSPGNO+1
SET ACHSPTOT=0
SET ACHSPNOT=0
+2 QUIT
+3 ;
HDR ;
+1 WRITE @IOF,$$C^XBFUNC("MASTER DELIVERY ORDER LISTING FOR: "_$$LOC^ACHS,IOM),!
+2 IF ACHSRPT=1
WRITE $$C^XBFUNC("BY DATE OF ESTIMATED SERVICE",IOM),!
+3 IF ACHSRPT=2
WRITE $$C^XBFUNC("BY DATE OF ISSUE",IOM),!
+4 SET X="FOR PATIENTS TREATED BY: "_$PIECE(^AUTTVNDR(ACHSVPTR,0),U)
+5 WRITE !?2,ACHSRDT,?IOM-$LENGTH(X)/2,X,?IOM-10,"Page ",ACHSPGNO
+6 SET X=$SELECT(ACHSRTYP="I":"FOR AO PAYMENT FOR SERVICES PROVIDED : ",ACHSRTYP="F":"FOR FI PAYMENT FOR SERVICES PROVIDED : ",ACHSRTYP="D":"FOR DENTAL SERVICES PROVIDED : ",1:"DATE(S) OF SERVICE: ")
+7 WRITE !,$$C^XBFUNC(X_$$FMTE^XLFDT(ACHSRDAT)_" - "_$$FMTE^XLFDT(ACHSEDAT),IOM),!!
+8 WRITE "IHS #",?16,"PATIENT NAME",?38,"DOB",?43,"S",?45,"TRB",?49,"SOC SEC #",?59,"COMM-CD",?67,"ESTDOS",?74,"PURCH OR #",?85,"EST. COST",?96,"COV",?100,"ACCT NO",!
+9 WRITE $$R("-",6),?7,$$R("-",28),?36,$$R("-",6),?43,$$R("-",1),?45,$$R("-",3),?49,$$R("-",9),?59,$$R("-",7),?67,$$R("-",6),?74,$$R("-",10),?85,$$R("-",10),?96,$$R("-",3),?100,$$R("-",15),!
+10 QUIT
+11 ;
FTR1 ;
+1 IF ACHSTFLG=0
WRITE !?40,"NO. ITEMS (THIS PAGE): ",$JUSTIFY(ACHSPNOT,3),?69,"SUB-TOTAL(THIS PAGE):",?95,$JUSTIFY($FNUMBER(ACHSPTOT,",",2),15)
+2 IF ACHSTFLG>0
WRITE !?7,"TOTAL PAGES IN REPORT: ",$JUSTIFY(ACHSPGNO,3),?40,"NO ITEMS (ALL PAGES):",$JUSTIFY(ACHSGNOT,5),?69,"GRAND TOTAL(ALL PAGES):",?95,$JUSTIFY($FNUMBER(ACHSGTOT,",",2),15)
+3 QUIT
+4 ;
FTR1A ;
+1 WRITE !!," Date: ",$$R("_",13),?25,"Funds Available Signature:",?60,$$R("_",30),!!
+2 WRITE " Date: ",$$R("_",13),?25,"Ordering Official Signature:",?60,$$R("_",30),!!
+3 WRITE " Date: ",$$R("_",13),?25,"Vendor Services Received:",?60,$$R("_",30),!!
+4 QUIT
+5 ;
R(X,Y) QUIT $$REPEAT^XLFSTR(X,Y)
+1 ;
