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

ACHSDNL.m

Go to the documentation of this file. 
  1. ACHSDNL ; IHS/ITSC/PMF - DENIAL LTR/FS (OPTS) (1/6) ;   [ 10/31/2003  11:44 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**4,6,24**;JUNE 11, 2001;Build 43
  1.  ;ACHS*3.1*4  allow different numbers of office copies
  1.  ;
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ VAR NOT SET PRIOR TO $O
  1.  ;
  1.  D SETCK^ACHSDF1    ;CHECK SITE PARAMETERS AND CLEAN INCOMPLETE DOCS
  1.  Q:$G(ACHDXQT)
  1.  K X2,X3
  1. SEL ;
  1.  D QSEL
  1.  S Y=$$DIR^ACHS("N^1:2:0","Select",1,"","^D QSEL^ACHSDNL",2)
  1.  ;
  1.  G PAT:Y=1       ;PATIENT INPUT AND LOOKUP
  1.  G BDT:+Y=2      ;DATE INPUT
  1.  D END
  1.  Q
  1.  ;
  1. PAT ; --- Select Denial
  1.  S ACHDOCT="denial"
  1.  K DFN
  1.  D ^ACHSDLK                    ;PATIENT LOOKUP
  1.  I $D(ACHDLKER) D END Q
  1.  ;
  1.  I $$DN^ACHS(0,8)="Y" W !!!,*7,*7,?15,"Document Cancelled",!! S %=$$DIR^ACHS("Y","Do You Want To Print It Anyway","NO","Enter 'YES' to print this CALCELLED document","",2) G END:$D(DTOUT),PAT:$D(DUOUT),PAT:'%
  1. P4 ;
  1.  ;
  1.  I '$O(^ACHSDEN(DUZ(2),"D",ACHSA,200,0)),'$O(^ACHSDEN(DUZ(2),"D",ACHSA,210,0)) G CPY
  1.  S %=$$DIR^ACHS("Y","Print For Specific Vendor","NO","Enter 'NO' to print all Vendors, 'YES' to select the vendor","",2)
  1.  I $D(DTOUT) D END Q
  1.  G PAT:$D(DUOUT)
  1.  I '% G CPY
  1.  S ACHDP=0
  1.  W !
  1. P5 ;
  1.  S ACHDP=ACHDP+1
  1.  I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,100)) W *7,!,"NO PRIMARY PROVIDER FOR THIS DENIAL" G P6
  1.  ;
  1.  I $$DN^ACHS(100,1)="Y" S ACHDPROV(ACHDP)=$P($G(^AUTTVNDR($$DN^ACHS(100,2),0)),U)_"^Y^"_$$DN^ACHS(100,2) G P5A
  1.  S ACHDPROV(ACHDP)=$$DN^ACHS(100,3)_"^N"
  1. P5A ;
  1.  W !,ACHDP,".   ",$P(ACHDPROV(ACHDP),U)
  1.  S ACHDX=0,ACHDP=ACHDP+1
  1. P6 ;
  1.  S X=0 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ WAS NOT DISPLAYING VND IN P7
  1.  G P7:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,200))
  1.  S ACHDX=$O(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDX))
  1.  G P6:ACHDX=0
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ X IS NOW SET IN P6+1
  1.  ;I +ACHDX=0 S X=0 G P7 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ
  1.  G P7:+ACHDX=0 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ
  1.  S ACHDPROV(ACHDP)=$P($G(^AUTTVNDR($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDX,0)),U),0)),U)_"^Y^"_$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHDX,0)),U)
  1.  W !,ACHDP,".   ",$P(ACHDPROV(ACHDP),U)
  1.  S ACHDP=ACHDP+1
  1.  G P6
  1.  ;
  1. P7 ;
  1.  S X=$O(^ACHSDEN(DUZ(2),"D",ACHSA,210,X))
  1.  I X=""&(ACHDP<2) W "NO SECONDARY PROVIDERS FOR THIS DENIAL",! G P8
  1.  I (X="")!(+X=0) G P8
  1.  S ACHDPROV(ACHDP)=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,X,0)),U)_"^N^"_X
  1.  W !,ACHDP,".   ",$P(ACHDPROV(ACHDP),U)
  1.  S ACHDP=ACHDP+1
  1.  G P7
  1.  ;
  1. P8 ;
  1.  S %=$$DIR^ACHS("N^1:"_(ACHDP-1),"PROVIDER TO PRINT LETTERS FOR","","Enter the number of the VENDOR from the list above..","",2)
  1.  I $D(DTOUT) D END Q
  1.  G PAT:$D(DUOUT)
  1.  S ACHDPROZ=ACHDPROV(%)
  1.  G CPY
  1.  ;
  1. BDT ; --- Input begin date
  1.  K ACHDBDT,ACHDEDT
  1.  S ACHDBDT=$$DATE^ACHS("B","DENIAL LTRS/FACE SHEET")
  1.  I ACHDBDT<1 K ACHDBDT G SEL
  1.  ;
  1. EDT ; --- Input end date
  1.  S ACHDEDT=$$DATE^ACHS("E","DENIAL LTRS/FACE SHEET")
  1.  G:ACHDEDT<1 BDT
  1.  I $$EBB^ACHS(ACHDBDT,ACHDEDT) G BDT
  1.  ;
  1. CPY ; --- Set default number of copies
  1.  S (ACHDCPAT,ACHDCFAC,ACHDCVEN)=0
  1.  F %=3:1:5 S ACHD("CPY",%)=+$P($G(^ACHSDENR(DUZ(2),0)),U,%)
  1.  ;
  1.  ;4/5/02  pmf  add choice and default for office copies
  1.  S ACHD("CPY",8)=+$P($G(^ACHSDENR(DUZ(2),0)),U,8)  ; ACHS*3.1*4
  1.  ;
  1. C1 ;
  1.  I $D(ACHDPROZ) G SEL:$D(DUOUT),C2
  1.  S ACHDCPAT=$$DIR^ACHS("N^0:10:0","How many LETTERS for the patient? ",ACHD("CPY",3),"","^D Q1^ACHSDNL",2)
  1.  G SEL:$D(DUOUT)
  1.  I $D(DTOUT) D END Q
  1. C2 ;
  1.  S ACHDCVEN=$$DIR^ACHS("N^0:10:0","How many LETTERS for EACH vendor? ",ACHD("CPY",4),"","^D Q1^ACHSDNL",2)
  1.  G C1:$D(DUOUT)
  1.  I $D(DTOUT) D END Q
  1.  ;
  1. C2B ;
  1.  ;ACHS*3.1*4  4/5/02  pmf  add choice and default for office copies.  whole tag new
  1.  ;
  1.  S ACHDCOFF=$$DIR^ACHS("N^0:10:0","How many OFFICE COPIES?           ",ACHD("CPY",8),"","^D Q1^ACHSDNL",2)
  1.  G C2:$D(DUOUT)
  1.  I $D(DTOUT) D END Q
  1.  ;
  1. C3 ;
  1.  S ACHDCFAC=$$DIR^ACHS("N^0:10:0","How many copies of the FACT SHEET? ",ACHD("CPY",5),"","",2)
  1.  ;4/5/02  pmf  add choice and default for office copies
  1.  ;G C2:$D(DUOUT)  ; ACHS*3.1*4
  1.  G C2B:$D(DUOUT)  ; ACHS*3.1*4
  1.  ;
  1.  I $D(DTOUT) D END Q
  1.  S:'$D(ACHDBDT) (ACHDBDT,ACHDEDT)=0
  1.  S:'$D(ACHSA) ACHSA=0
  1.  ;
  1. DEV ; --- Select print device
  1.  W !!
  1.  S %ZIS="OPQ"
  1.  D ^%ZIS
  1.  I POP D HOME^%ZIS D END Q
  1.  G:'$D(IO("Q")) ^ACHSDNL1
  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="START^ACHSDNL1",ZTDESC="CHS Denial Letters and Fact Sheets"
  1.  ;
  1.  ;ACHS*3.1*4  4/5/02  pmf  add choice and default for office copies
  1.  ;F %="ACHDBDT","ACHSA","ACHDEDT","ACHDCPAT","ACHDCFAC","ACHDCVEN" S ZTSAVE(%)=""  ; ACHS*3.1*4
  1.  ;F %="ACHDBDT","ACHSA","ACHDEDT","ACHDCPAT","ACHDCFAC","ACHDCVEN","ACHSDCOFF" S ZTSAVE(%)=""  ;  ACHS*3.1*4
  1.  ;
  1.  F %="ACHDBDT","ACHSA","ACHDEDT","ACHDCPAT","ACHDCFAC","ACHDCVEN","ACHDCOFF" S ZTSAVE(%)=""  ;  ACHS*3.1*5 12/06/2002
  1.  ;
  1.  ;
  1.  D ^%ZTLOAD
  1.  G:'$D(ZTSK) DEV
  1.  ;
  1. END ;EP
  1.  D ^%ZISC
  1.  ;
  1.  ;ACHS*3.1*4  04/05/02  pmf  add ACHDCOFF
  1.  ;K ACHD,ACHDCFAC,ACHDCPAT,ACHDCVEN,ACHSA,ACHDP,ACHDPROZ,ACHSBPNO  ;  ACHS*3.1*4
  1.  K ACHD,ACHDCFAC,ACHDCOFF,ACHDCPAT,ACHDCVEN,ACHSA,ACHDP,ACHDPROZ,ACHSBPNO  ;  ACHS*3.1*4
  1.  K DTOUT,DUOUT,DIW,DIWL,DIWR,DIWT,ZTSK
  1.  K ACHDALT,ACHDNAMP,ACHDONE,ACHDPRE,ACHSCNT,ACHSDBCN,ACHSDBCP,ACHSIII,ACHSNFAC,ACHSQUIT,ACHSST,ACHSVPT ;ACHS*3.1*24
  1.  Q
  1.  ;
  1. Q1 ;EP - From DIR.
  1.  W !!,"You may print any number of letters from 0 to 10.",!!
  1.  Q
  1.  ;
  1. QSEL ;EP - From DIR.
  1.  W !!?20,"1) Print individual ltrs & fact sheet",!!?20,"2) Print range by Issue Date"
  1.  Q
  1.  ;
  1. NAMERR ;
  1.  W !!,*7,"No valid PATIENT NAME in this file.",!,"No letter may be printed until a valid patient is entered.",!!
  1.  G PAT
  1.  ;