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

ACHSMD0.m

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