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

ACHSDST.m

Go to the documentation of this file. 
  1. ACHSDST ; IHS/ITSC/PMF - DOCUMENT STATUS REPORT ;   [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1.  ;
  1. TITLE ;;DOCUMENT STATUS
  1.  S ACHSIO=IO
  1.  K X2,X3
  1. BDT ;
  1.  S ACHSBDT=$$DATE^ACHS("B",$P($T(TITLE),";",3),"ISSUE")
  1.  G K:$D(DUOUT)!$D(DTOUT)!(ACHSBDT<1)
  1. EDT ;
  1.  S ACHSEDT=$$DATE^ACHS("E",$P($T(TITLE),";",3),"ISSUE")
  1.  G K:$D(DTOUT)!(ACHSEDT<1),BDT:$D(DUOUT)
  1.  G:$$EBB^ACHS(ACHSBDT,ACHSEDT) EDT
  1. TYPE ;
  1.  W !!,"Which type of report?",!!,"  1.  OPEN DOCUMENTS only",!,"  2.  CLOSED DOCUMENTS only",!,"  3.  COMBINED list",!!,"  ENTER OPTION (1-3) 3//"
  1.  D READ^ACHSFU
  1.  I Y="" S Y=3
  1.  G K:$D(DTOUT),Q:Y?1"?".E,BDT:$D(DUOUT)
  1.  I "123"[Y&(Y>0)&(Y<4) S ACHSRPT=Y G DEV
  1.  W !!,*7,"  Enter only a 1, 2, or 3"
  1.  G TYPE
  1.  ;
  1. Q ;
  1.  W !!,"Choice 1 - only open documents will be listed.",!,"Choice 2 - only documents which have been paid or cancelled will be listed.",!,"Choice 3 - open and closed documents will be listed together."
  1.  G TYPE
  1.  ;
  1. DEV ;
  1.  S %=$$PB^ACHS
  1.  I %=U!$D(DTOUT)!$D(DUOUT) D K Q
  1.  I %="B" D VIEWR^XBLM("PRINT^ACHSDST"),EN^XBVK("VALM"),K Q
  1.  S %ZIS="OPQ"
  1.  D ^%ZIS
  1.  I POP D HOME^%ZIS G K
  1.  G:'$D(IO("Q")) PRINT
  1.  K IO("Q")
  1.  I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
  1.  S ZTRTN="PRINT^ACHSDST",ZTIO="",ZTDESC=$P($T(TITLE),";",3)_", Type "_ACHSRPT_", "_$$FMTE^XLFDT(ACHSBDT)_" to "_$$FMTE^XLFDT(ACHSEDT),ACHSQIO=ION_";"_IOST_";"_IOM_";"_IOSL
  1.  F ACHS="ACHSQIO","ACHSBDT","ACHSEDT","ACHSRPT" S ZTSAVE(ACHS)=""
  1.  D ^%ZTLOAD
  1.  G:'$D(ZTSK) DEV
  1. K ;
  1.  K ACHS,ACHSIO,ACHSQIO,ACHSBDT,ACHSEDT,ACHSRPT,ZTIO,ZTSK
  1.  D ^%ZISC
  1.  Q
  1.  ;
  1. PRINT ;EP - From TaskMan.
  1.  ;
  1.  D FC^ACHSUF
  1.  I $D(ACHSERR),ACHSERR=1 K ZTSK G KILL
  1.  S (ACHSTOTP,ACHSCNX,ACHSOPEN,ACHSTOTP("$"),ACHSCNX("$"),ACHSOPEN("$"))=0
  1.  S ACHST1=$$C^XBFUNC($S(ACHSRPT=1:"OPEN DOCUMENTS",ACHSRPT=2:"CLOSED DOCUMENTS",1:"OPEN AND CLOSED DOCUMENTS"),80),ACHST2=$$C^XBFUNC("For the period "_$$FMTE^XLFDT(ACHSBDT)_" through "_$$FMTE^XLFDT(ACHSEDT),80)
  1.  D BRPT^ACHSFU
  1.  D HDR
  1.  S X3=0,ACHSBDT=ACHSBDT-1
  1. A ; Main loop.
  1.  S ACHSBDT=$O(^ACHSF(DUZ(2),"TB",ACHSBDT))
  1.  G END:+ACHSBDT=0!(+ACHSBDT>ACHSEDT)
  1.  S ACHSTYPE=""
  1. B ;
  1.  S ACHSTYPE=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE))
  1.  G A:ACHSTYPE="",B:ACHSTYPE'="I"
  1.  S DA=0
  1. C ;
  1.  S DA=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA))
  1.  G A:+DA=0,A:'$D(^ACHSF(DUZ(2),"D",DA,0)) S ACHSSTS=$S($P(^(0),U,12)=3:"P",$P(^(0),U,12)=4:"C",1:"OPEN")
  1.  I ACHSRPT=1,"PC"[ACHSSTS G C
  1.  I ACHSRPT=2,"PC"'[ACHSSTS G C
  1.  S ACHSDOC1=$P(^ACHSF(DUZ(2),"D",DA,0),U),ACHSVPTR=$P(^(0),U,8),ACHSDOC2=$P(^(0),U,14),ACHS("$")=$P(^(0),U,9),ACHSTOS=$P(^(0),U,4),ACHSBLNK=+$P(^(0),U,3)
  1.  G A:ACHSVPTR']"",A:'$D(^AUTTVNDR(ACHSVPTR,0)) S ACHSVNDR=$P(^(0),U) S ACHSEIN="" S:$D(^(11)) ACHSEIN=$P(^(11),U)_" "_$P(^(11),U,2)
  1.  S ACHSDOC=ACHSDOC2_"-"_ACHSFC_"-"_ACHSDOC1
  1.  K ACHSNAME
  1.  S ACHS=$O(^ACHSF(DUZ(2),"TB",ACHSBDT,ACHSTYPE,DA,0))
  1.  I +ACHS>0,$D(^ACHSF(DUZ(2),"D",DA,"T",ACHS,0)) S DFN=$P(^(0),U,3) I +DFN>0,$D(^DPT(DFN,0)) S ACHSNAME=$P(^(0),U)
  1.  I '$D(ACHSNAME),ACHSBLNK S ACHSNAME=$S(ACHSBLNK=1:"* BLANKET",1:"* SPECIAL TRANS")
  1. D ;
  1.  G C:'$D(ACHSNAME)
  1.  S:$D(^ACHSF(DUZ(2),"D",DA,"PA")) ACHS("$")=+^("PA")
  1.  S:$D(^ACHSF(DUZ(2),"D",DA,"ZA")) ACHS("$")=+^("ZA")
  1. E ; 
  1.  I ACHSSTS="C" S ACHS("$")=0 F ACHS=0:0 S ACHS=$O(^ACHSF(DUZ(2),"D",DA,"T",ACHS)) Q:+ACHS=0  S ACHS("$")=+$P(^(ACHS,0),U,4)
  1.  S ACHSDOS=""
  1.  I $O(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",DA,0)) S ACHSDOS=$P(^ACHSF(DUZ(2),"D",DA,"T",$O(^ACHSF(DUZ(2),"TB",ACHSBDT,"P",DA,0)),0),U,10)
  1.  W $E(ACHSNAME,1,24),?25,$E(ACHSVNDR,1,26),?52,$E(ACHSBDT,4,7),$E(ACHSBDT,2,3)
  1.  W:ACHSDOS]"" "/",$E(ACHSDOS,4,7)
  1.  W ?64
  1.  G P1:"PC"'[ACHSSTS
  1.  W $S(ACHSSTS="P":"PAID",1:"CANCEL")
  1.  S X=ACHS("$")
  1.  D COMMA^%DTC
  1.  W ?80-$L(X),X
  1.  G P2
  1.  ;
  1. P1 ;
  1.  I +ACHS("$")'=0 S X=ACHS("$") D COMMA^%DTC W ?80-$L(X),X
  1. P2 ;
  1.  W !,ACHSDOC,?25,ACHSEIN,?52,$S(ACHSTOS=1:"HOSPITAL",ACHSTOS=2:"DENTAL",ACHSTOS=3:"OUTPATIENT",1:"")
  1.  I ACHSSTS="P" S ACHSTOTP=ACHSTOTP+1,ACHSTOTP("$")=ACHSTOTP("$")+ACHS("$") G P3
  1.  I ACHSSTS="C" S ACHSCNX=ACHSCNX+1,ACHSCNX("$")=ACHSCNX("$")+ACHS("$") G P3
  1.  S ACHSOPEN=ACHSOPEN+1,ACHSOPEN("$")=ACHSOPEN("$")+ACHS("$")
  1. P3 ; Ask RTRN if EOP, do header, go main loop.
  1.  W !!
  1.  I $Y>ACHSBM D RTRN^ACHS G KILL:$D(DUOUT)!$D(DTOUT) D HDR
  1.  G C
  1.  ;
  1. END ; Print totals, ask RTRN, write IOF.
  1.  W !,$$REPEAT^XLFSTR("-",79),!
  1.  S X2="2$",X3=14
  1.  I ACHSTOTP S X=ACHSTOTP("$") D COMMA^%DTC W "TOTAL PAID DOCUMENTS:",$J(ACHSTOTP,11),?40,"TOTAL DOLLARS PAID:       ",X,!
  1.  I ACHSCNX S X=ACHSCNX("$") D COMMA^%DTC W "TOTAL CANCELLED DOCUMENTS:",$J(ACHSCNX,6),?40,"TOTAL DOLLARS CANCELLED:  ",X,!
  1.  I ACHSOPEN S X=ACHSOPEN("$") D COMMA^%DTC W "TOTAL OPEN DOCUMENTS:",$J(ACHSOPEN,11),?40,"TOTAL DOLLARS OPEN:       ",X
  1.  D RTRN^ACHS
  1.  W @IOF
  1. KILL ; Do ERPT, kill vars, quit.
  1.  I $D(ZTQUEUED) K ACHSFC
  1.  D ERPT^ACHS
  1.  K ACHSDOC,ACHSDOC1,ACHSDOC2,ACHSBLNK,ACHSCNX,ACHSDOS,ACHSTYPE,ACHSVNDR,ACHSEIN,ACHSOPEN,ACHSNAME,ACHSSTS,ACHSTOS,ACHSTOTP,ACHSVPTR
  1.  K DA,DFN,X2,X3
  1.  Q
  1.  ;
  1. HDR ; Print report header.
  1.  S ACHSPG=ACHSPG+1
  1.  W @IOF,!!,ACHSUSR,?71,"Page",$J(ACHSPG,3),!,$$C^XBFUNC("***  CONTRACT HEALTH MANAGEMENT SYSTEM  ***",80),!!,ACHSLOC,!?29,"DOCUMENT STATUS REPORT"
  1.  I $D(ZTQUEUED) W ?77-$L(ZTSK),"(",ZTSK,")"
  1.  W !,ACHSTIME,!,ACHST1,!,ACHST2,!!,"Patient Name",?25,"Provider of Service",?52,"Issue /DOS",!,"Document number",?25,"EIN Number",?52,"Type",?64,"Status",?73,"Amount",!,$$REPEAT^XLFSTR("=",79),!
  1.  Q
  1.  ;