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

ACHSMD2D.m

Go to the documentation of this file. 
  1. ACHSMD2D ; IHS/ITSC/PMF - PRINT DENIAL LISTING BY PROVIDER BY DATE OF SERVICE ;   [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ;    This is a new routine to accommodate new Denial/Deferred
  1.  ;    Services data structure at Alpha sites.
  1.  ;
  1. A0 ;
  1.  S (ACHSPGNO,ACHSLC,ACHSPTOT,ACHSGTOT,ACHSTFLG,ACHSPNOT,ACHSGNOT)=0
  1.  ;
  1.  ; Check for Hi-vol providers.
  1.  I '$D(^ACHSF(DUZ(2),18,"B")) W !!,*7,?5,"No High Volume Providers have been Identified for this Facility" G CANREQ
  1.  ;
  1.  ; Ask user select hi-vol provider.
  1.  S Y=$$HVP^ACHSMD0
  1.  G CANREQ:$D(DUOUT)!($D(DTOUT))
  1.  I +Y<1 W !!,*7,"No Vendors Selected" G CANREQ
  1.  S ACHSVPTR=+$P(Y,U),ACHSHVAB=$P(Y,U,2)
  1. A3 ;
  1.  D HELP(10,ACHSVPTR)
  1.  ;S ACHSRDAT=$$DIR^XBDIR("D","Enter Beginning Date ","","","","^D HELP^ACHSMD2D(99,ACHSVPTR)",1)
  1.  S ACHSRDAT=$$DIR^XBDIR("D^::E","Enter Beginning Date ","","","","^D HELP^ACHSMD2D(99,ACHSVPTR)",1)
  1.  G CANREQ:$D(DTOUT)!($D(DUOUT))
  1.  I '$D(^ACHSDEN(DUZ(2),"D","ES",ACHSRDAT)) W !!,*7,?5,"No Documents (Orders)  Available to Print on this Date" G A3
  1.  ;S ACHSEDAT=$$DIR^XBDIR("D","Enter Ending Date ","","","","^D HELP^ACHSMD2D(99,ACHSVPTR)",1)
  1.  S ACHSEDAT=$$DIR^XBDIR("D^::E","Enter Ending Date ","","","","^D HELP^ACHSMD2D(99,ACHSVPTR)",1)
  1.  G CANREQ:$D(DTOUT)!($D(DUOUT))
  1.  I $$EBB^ACHS(ACHSRDAT,ACHSEDAT) G A3
  1.  S ACHSJDAT=$E(ACHSRDAT,2,3)_$$JDT^ACHS(ACHSRDAT,1)
  1. TXFILE ;
  1.  S ACHSTXF=0
  1.  S Y=$$DIR^XBDIR("Y","Do you want generate a TX FILE for this REPORT ","N")
  1.  I $D(DUOUT)!($D(DTOUT)) G A3
  1.  I Y=0 G A7
  1.  S ACHSTXF=1,X="achsm2"_ACHSHVAB_"."_ACHSJDAT
  1.  I '$D(^AFSTXLOG(DUZ(2),1,"B",X)) G A5
  1.  U IO(0)
  1.  S Y=$$DIR^XBDIR("Y","A TX FILE Already Exists for this Date - Continue (Y/N) ","","","","",1)
  1.  I $D(DUOUT)!($D(DTOUT))!(+Y=0) G TXFILE
  1. A5 ;
  1.  I '$L($$AOP^ACHS(2,1)) D NODIR^ACHSMD0 G CANREQ
  1.  S ACHSZFN="achsm2"_ACHSHVAB,ACHSZOPT=1,ACHSZDIR=$$AOP^ACHS(2,1)
  1.  D ARCHLIST^ACHSARCH
  1.  S ACHSZFN=$$AOP^ACHS(2,1)_"achsm2"_ACHSHVAB_"."_ACHSJDAT,ACHSZIN=0
  1.  D OPENHFS^ACHSTCK1
  1.  S ACHSHFS1=ACHSZDEV
  1. A7 ;
  1.  U IO(0)
  1.  W !
  1.  K %ZIS
  1.  S %ZIS="NP",%ZIS("A")="Enter Printer Output Device: "
  1.  D ^%ZIS
  1.  K %ZIS
  1.  I POP G CANREQ
  1.  S ACHSPTRN=ION
  1.  I IOM<132 W !!,*7,"Device Right Margin < 132 Char -- Select another Device" G A7
  1.  S ACHSPTR=IO,ACHSRDT=$$HTE^XLFDT($H)
  1.  D CHK16^ACHSPS16
  1.  G A0:$D(DUOUT)
  1.  I '$D(ACHS("PRINT","ERROR")) G A7A
  1.  G A0:$$DIR^XBDIR("E","","","","","",1),CANREQ
  1. A7A ;
  1.  U IO(0)
  1.  W !!?10,"Your Request is now being Processed",!
  1. A7B ;
  1.  S IOP=ACHSPTRN
  1.  D ^%ZIS
  1.  I POP>0 U IO(0) W !!,"Device Unavailable" G CANREQ
  1. A7C ;
  1.  I $D(ACHS("PRINT",16)) U ACHSPTR W @ACHS("PRINT",16)
  1.  S ACHSIODV=ACHSPTR,ACHSPASS=1
  1.  ;
  1.  D HDR1,HDR2
  1.  I ACHSTXF S ACHSIODV=ACHSHFS1,ACHSPASS=2 D HDR1,HDR2 S ACHSIODV=ACHSPTR,ACHSPASS=1
  1.  S ACHSZR=ACHSRDAT-1
  1. B0 ;
  1.  S ACHSZR=$O(^ACHSDEN(DUZ(2),"D","ES",ACHSZR))
  1.  G BEND:ACHSZR=""!(ACHSZR>ACHSEDAT)
  1.  S ACHSZRR=""
  1. B1 ; 
  1.  S ACHSZRR=$O(^ACHSDEN(DUZ(2),"D","ES",ACHSZR,ACHSZRR))
  1.  G B0:ACHSZRR=""
  1.  S X=0
  1.  S:$D(^ACHSDEN(DUZ(2),"D",ACHSZRR,100))#2 X=$P(^ACHSDEN(DUZ(2),"D",ACHSZRR,100),U,2)
  1.  I X=0 G B1
  1.  I X'=ACHSVPTR G B1
  1.  S ACHSX=$G(^ACHSDEN(DUZ(2),"D",ACHSZRR,0))
  1.  I $E(ACHSX)="#" G B1
  1.  G B3
  1.  ;
  1. B2 ;
  1.  S ACHSPASS=2,ACHSIODV=ACHSHFS1
  1. B3 ;
  1.  U ACHSIODV
  1.  S DFN=$P(ACHSX,U,7),ACHSFAC=$P(ACHSX,U,8)
  1.  S ACHSFAC=DUZ(2)
  1.  I +DFN=0 G B5
  1.  W $J($$HRN^ACHS(DFN,ACHSFAC),6),?7,$E($P($G(^DPT(DFN,0)),U),1,29)
  1.  S X=$P($G(^DPT(DFN,0)),U,3)
  1.  W ?38,$E(X,4,5),"-",$E(X,6,7),"-",1700+$E(X,1,3),?49,$P($G(^DPT(DFN,0)),U,2),?53,$P($G(^AUTTTRI($P($G(^AUPNPAT(DFN,11)),U,8),0)),U,2)
  1.  G B10
  1.  ;
  1. B5 ;
  1.  S ACHSY=$G(^ACHSDEN(DUZ(2),"D",ACHSZRR,10)),ACHSNAME=$P(ACHSY,U)_"  "_$P(ACHSY,U,2)_", "_$P(ACHSY,U,3)_", ",X=$P(ACHSY,U,4),Y=$P($G(^DIC(5,X,0)),U,2),ACHSNAME=ACHSNAME_Y_"  "_$P(ACHSY,U,5)
  1.  W ?7,$E(ACHSNAME,1,50)
  1. B10 ;
  1.  S X=$P($G(^ACHSDEN(DUZ(2),"D",ACHSZRR,400)),U,2)
  1.  S X=$P($G(^ACHSMPRI(X,0)),U)
  1.  ;
  1.  W ?58,$S($L(X):$E(X,1,4),1:"??")
  1. XXX ;
  1.  W ?63,$P($G(^ACHSDEN(DUZ(2),"D",ACHSZRR,100)),U,10)
  1.  ;
  1. B11 ;
  1.  S X=$P(^ACHSDEN(DUZ(2),"D",ACHSZRR,250),U),Y=$P($G(^ACHSDENS(X,0)),U)
  1.  W ?66,$E(Y,1,25),?93,$J($P(ACHSX,U),14)
  1.  S X=+$P($G(^ACHSDEN(DUZ(2),"D",ACHSZRR,100)),U,8)
  1.  S:ACHSPASS=1 ACHSPTOT=ACHSPTOT+X,ACHSGTOT=ACHSGTOT+X
  1.  W ?109,$J(X,10,2)
  1.  G B25:'$D(^ACHSDEN(DUZ(2),"D",ACHSZRR,950))
  1.  S Y="",X=0,ACHS=0
  1.  F ACHSF=1:1 S X=$O(^ACHSDEN(DUZ(2),"D",ACHSZRR,950,X)) Q:+X=0  S Y=$G(^ACHSDEN(DUZ(2),"D",ACHSZRR,950,X,0)) I Y?6N.N1" ".1E.1E S ACHS=$L(Y) Q
  1.  I ACHS=0 G B25
  1.  S X=$P(Y," ",1)
  1.  W ?121,$E(X,1,7)
  1.  S X=$P(Y," ",2)
  1.  W ?129,$E(X,1,2)
  1. B25 ;
  1.  W !
  1.  I ACHSPASS=2 G B26
  1.  S ACHSPNOT=ACHSPNOT+1,ACHSGNOT=ACHSGNOT+1,ACHSLC=ACHSLC+1
  1. B26 ;
  1.  I ACHSLC#45=0 D FTR1,FTR1A,HDR1,HDR2
  1.  I ACHSPASS=2 S ACHSIODV=ACHSPTR G B1
  1.  I 'ACHSTXF G B1
  1.  S ACHSIODV=ACHSHFS1
  1.  G B2
  1.  ;
  1. BEND ;
  1.  U ACHSPTR
  1.  D FTR1
  1.  I ACHSTXF U ACHSHFS1 D FTR1
  1.  S ACHSTFLG=ACHSTFLG+1
  1.  U ACHSPTR
  1.  D FTR1,FTR1A
  1.  W !!
  1.  I ACHSTXF U ACHSHFS1 D FTR1,FTR1A W !!
  1.  I $D(ACHS("PRINT",16)) U ACHSPTR D 10^ACHSPS16
  1.  S IO=ACHSPTR
  1.  D ^%ZISC
  1.  I 'ACHSTXF G EXIT
  1.  S IO=ACHSHFS1
  1.  D ^%ZISC
  1.  S ACHSEXFS="achsm2"_ACHSHVAB_"."_ACHSJDAT
  1.  D TXLOGADD^ACHSTXUT
  1.  G EXIT:ACHSY>0
  1.  U IO(0)
  1.  W *7,!,"Entry NOT Successfully Posted to Data Tranmission Log - Notify Supervisor",!
  1.  I $$DIR^XBDIR("E","Enter <RETURN> to Continue ")
  1.  G EXIT
  1.  ;
  1. CANREQ ;
  1.  W !!?20,"Request Cancelled"
  1.  D RTRN^ACHS
  1. EXIT ;
  1.  D EN^XBVK("ACHS"),^ACHSVAR
  1.  K DIR,DIC,DFN
  1.  Q
  1.  ;
  1. HDR1 ; Print header.
  1.  S:ACHSPASS=1 ACHSPGNO=ACHSPGNO+1,ACHSPTOT=0,ACHSPNOT=0
  1.  U ACHSIODV
  1.  W @IOF,$$C^XBFUNC("HIGH VOLUME PROVIDER DENIAL LISTING FOR: "_$$LOC^ACHS,132)
  1.  S X="FOR PATIENTS TREATED BY: "_$P(^AUTTVNDR(ACHSVPTR,0),U)
  1.  W !?2,ACHSRDT,?132-$L(X)/2,X,?122,"Page ",ACHSPGNO,!,$$C^XBFUNC("DATE OF SERVICE: "_$$FMTE^XLFDT(ACHSRDAT),132),!!
  1.  Q
  1.  ;
  1. HDR2 ;
  1.  U ACHSIODV
  1.  W "IHS #",?16,"PATIENT NAME",?40,"DOB",?48,"SEX",?53,"TRB",?58,"MP",?62,"TS",?66,"REASON  FOR  DENIAL",?93,"DENIAL NUMB",?109,"EST. COST",?121,"ACCT NO",?129,"FC",!
  1.  W "------",?7,"----------------------------",?38,"--------",?48,"---",?53,"---",?58,"--",?62,"--",?66,"-------------------------",?93,"--------------",?109,"----------",?121,"-------",?129,"--",!
  1.  Q
  1.  ;
  1. FTR1 ;
  1.  I ACHSTFLG=0 W !?40,"NO ITEMS (THIS PAGE): ",$J(ACHSPNOT,3),?69,"SUB-TOTAL (THIS PAGE) ",?104,$J(ACHSPTOT,15,2)
  1.  I ACHSTFLG>0 W !?7,"TOTAL PAGES IN REPORT: ",$J(ACHSPGNO,3),?40,"NUMBER OF ITEMS (ALL PAGES): ",$J(ACHSGNOT,5),?77,"GRAND TOTAL (ALL PAGES) ",?104,$J(ACHSGTOT,15,2)
  1.  Q
  1.  ;
  1. FTR1A ;
  1.  W !!," Date: _____________",?25,"Authorized Facility Signature:",?60,"______________________________",!!
  1.  ;W " Date: _____________",?25,"Ordering Official Signature:",?60,"______________________________",!!
  1.  ;W " Date: _____________",?25,"Vendor Services Received:",?60,"______________________________",!!
  1.  Q
  1.  ;
  1. HELP(Z,V) ;EP - From DIR.  Z = Number of dates to display. V = Vendor.
  1.  N X,Y
  1.  S X=3991231,Y=0
  1.  W !!,"Recent MDEL dates:"
  1.  F  S X=$O(^ACHSDEN(DUZ(2),"D","ES",X),-1) Q:'X  S Y=Y+1 Q:Y>Z  W !?20,$$FMTE^XLFDT(X) I 'Y#10 D RTRN^ACHS Q:$G(ACHSQUIT)  ; The reverse $ORDER lists as error to %INDEX.
  1.  K ACHSQUIT
  1.  Q
  1.  ;