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

ACHSSVRQ.m

Go to the documentation of this file. 
  1. ACHSSVRQ ; IHS/ITSC/PMF - SELECT AND PRINT AO SPECIAL VENDOR REPORT ;  [ 10/16/2001   8:16 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001
  1.  ;
  1. A2 ;
  1.  I '$D(^ACHSAOP(DUZ(2),21)) W *7,!,"No Special Vendors have been identified",!,"in the CHS AREA OFFICE PARAMETERS file." G ZEND
  1.  W !
  1.  S DIC="^ACHSAOP("_DUZ(2)_",21,",DIC(0)="QAZEM"
  1.  D ^DIC
  1.  G ZEND:$D(DUOUT)!($D(DTOUT))!(+Y<1)
  1.  S ACHSEINP=$P(Y,U,2),ACHSEIN=$P(^AUTTVNDR(ACHSEINP,11),U,13)
  1. B0 ;
  1.  G NOREPORT:'$D(^ACHSSVR(ACHSEIN))
  1. B1A ;
  1.  S ACHSFAX=$$DIR^XBDIR("Y","Do you want a FAX Cover Sheet Generated for This Vendor (Y/N) ","Y","","","",1)
  1.  G A2:$D(DIRUT)!($D(DTOUT))!($D(DUOUT))
  1. B0C ;
  1.  S %=$$PB^ACHS
  1.  I %=U!$D(DTOUT)!$D(DUOUT) Q
  1.  I %="B" D VIEWR^XBLM("PRINT^ACHSSVRQ"),EN^XBVK("VALM") Q
  1.  S ACHSIOQ="",%ZIS="PQ"
  1.  D ^%ZIS
  1.  S ACHSIO=IO
  1.  I $D(IO("Q"))=1 S ACHSIOQ=IO("Q")
  1.  I ACHSIOQ="" G PRINT
  1.  I $D(IO("S"))!($E(IOST)'="P") G B0C
  1. ZTLOAD ;
  1.  S ZTRTN="PRINT^ACHSSVRQ",ZTDESC="PRINT SPECIAL AO VENDOR REPORTS",ZTIO=ION
  1.  F %="ACHSEIN","ACHSFAX","ACHSEINP" S ZTSAVE(%)=""
  1.  D ^%ZTLOAD
  1.  K IO("Q")
  1.  D HOME^%ZIS
  1.  K IOP
  1.  D KILL^%ZTLOAD
  1.  G A2
  1.  ;
  1. PRINT ;EP - From TaskMan. 
  1.  S (ACHSFAC,ACHSNMS,ACHSSEQ)="",(ACHSDCNT,ACHSPGNO)=0
  1.  I ACHSFAX=1 D FAX
  1.  S ACHSDATE=$$HTE^XLFDT($H)
  1.  I '$D(^ACHSSVR(ACHSEIN,"N")) D INDEX
  1.  D PGHDR
  1. B2 ;
  1.  S ACHSFAC=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
  1.  G PRTEND:+ACHSFAC=0
  1. B3 ;
  1.  S ACHSNMS=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
  1.  G B2:ACHSNMS=""
  1. B4 ;
  1.  S ACHSSEQ=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS,ACHSSEQ))
  1.  G B3:+ACHSSEQ=0
  1.  S ACHSX=$G(^ACHSSVR(ACHSEIN,ACHSFAC,ACHSSEQ))
  1.  K DIC
  1.  S DIC="^AUTTLOC(",D="C",DIC(0)="",X=ACHSFAC
  1.  D IX^DIC
  1.  I +Y<1 U IO(0) W "INVALID FACILITY CODE" H 3 G A2
  1.  S ACHSFACN=$E($P($G(^DIC(4,+Y,0)),U),1,12)
  1.  I $Y>55 D PGHDR
  1.  S X=ACHSX
  1.  W ACHSFACN,?14,$E($E(X,103,118),1,16),?32,$E(X,4,4),"-",$E(X,5,7),"-",$E(X,8,12),?45,$E(X,13,14),"-",$E(X,67,67),?51,$E(X,34,39),?59
  1.  S ACHSDCNT=ACHSDCNT+1
  1.  W $E(X,63,64),"/",$E(X,65,66),"/",$E(X,61,62),?70
  1.  S V=$E(X,69,76)/100
  1.  W $J(V,9,2),!," (",ACHSFAC,")",?14,"TRIBE-CD=",$E(X,151,153),"  COMM-CD=",$E(X,154,160),!
  1.  I $E(X,119,119)=" "!($E(X,119,119)="") W ! G B4
  1.  W ?14,"<",$E(X,119,134),">",!
  1.  I $E(X,135,136)="  " W !! G B4
  1.  W ?14,"<",$E(X,135,150),">",!!
  1.  G B4
  1.  ;
  1. PRTEND ; End printing, print totals.
  1.  U IO
  1.  W !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
  1.  Q:ACHSIOQ'=""
  1.  U IO(0)
  1.  S Y=$$DIR^XBDIR("Y","Do You want to Select Another Vendor ","N","","","",1)
  1.  G ZEND:+Y=0,A2
  1.  ;
  1. ZEND ; Close device, kill vars, quit.
  1.  I $$DIR^XBDIR("E","Press RETURN...")
  1.  I $G(IO) D ^%ZISC
  1.  K ACHSEIN,ACHSFAX
  1.  Q
  1.  ;
  1. NOREPORT ; No information in ACHSAOP(DUZ(2),"SVR",ACHSEIN
  1.  U IO(0)
  1.  W !,"No Report available for this Vendor"
  1.  S Y=$$DIR^XBDIR("E","Enter <RETURN> to select another Vendor or '^' to Exit")
  1.  G A2:Y=1,ZEND:Y=0
  1. PGHDR ; Print report header.
  1.  U IO
  1.  S ACHSPGNO=ACHSPGNO+1
  1.  W @IOF,$$C^XBFUNC("CHS AUTHORIZATIONS FROM "_$$LOC^ACHS_" FACILITIES",80)
  1.  W !,$$C^XBFUNC("FOR "_$P($G(^AUTTVNDR(ACHSEINP,0)),U),80)
  1.  S Z=^ACHSSVR(ACHSEIN,0),A=$P(Z,U,1),A=$E(A,3,4)_"/"_$E(A,5,6)_"/"_$E(A,1,2),B=$P(Z,U,2),B=$E(B,3,4)_"/"_$E(B,5,6)_"/"_$E(B,1,2)
  1.  W !,$$C^XBFUNC("FOR AUTHORIZATIONS ISSUED BETWEEN "_A_" AND "_B,80)
  1.  W !!,ACHSDATE,?70,"PAGE ",ACHSPGNO,!!,$$REPEAT^XLFSTR("-",80),!,"LOCATION",?14,"PATIENT NAME",?32,"DOCUMENT #",?45,"TYPE",?51,"IHS #",?59,"AUTH DTE",?70,"$$ AMOUNT",!,$$REPEAT^XLFSTR("-",80),!
  1.  Q
  1.  ;
  1. FAX ;EP - Print FAX cover sheet for vendor.
  1.  U IO
  1.  W @IOF,!!!!!,$$C^XBFUNC("INDIAN HEALTH SERVICE",80),!,$$C^XBFUNC($$LOC^ACHS,80)
  1.  W !,$$C^XBFUNC($P(^AUTTLOC(DUZ(2),0),U,12),80)
  1.  S X=$P(^AUTTLOC(DUZ(2),0),U,13),Y=$P(^AUTTLOC(DUZ(2),0),U,14),Z=$P(^DIC(5,+Y,0),U,2)
  1.  W !,$$C^XBFUNC(X_", "_Z_"  "_$P(^AUTTLOC(DUZ(2),0),U,15),80)
  1.  W !!!!!!?10,"DATE:   ",$$FMTE^XLFDT(DT)
  1.  W !!!!?10,"DELIVER TO:",?25,$E($P(^AUTTVNDR(ACHSEINP,0),U,1),1,30)
  1.  W !?25,$P(^AUTTVNDR(ACHSEINP,13),U,1)
  1.  W !?25,$P(^AUTTVNDR(ACHSEINP,13),U,2)," "
  1.  S Y=$P(^AUTTVNDR(ACHSEINP,13),U,3),Z=$P(^DIC(5,+Y,0),U,2)
  1.  W Z,"  ",$P(^AUTTVNDR(ACHSEINP,13),U,4)
  1.  W !!!!?10,"FAX #: ",?25,$P(^AUTTVNDR(ACHSEINP,11),U,14)
  1.  W !!!!!!!?10,"FROM:  ",?25,"Contract Health Services"
  1.  W !?25,$E($$LOC^ACHS,1,30)
  1.  W !!!!!!?10,"SUBJECT:  ",?25,"CHS PURCHASE ORDERS"
  1.  W !!
  1.  Q
  1.  ;
  1. INDEX ;EP - Create print index for ^ACHSSVR & begin & end dates.
  1.  S ACHSI="",ACHSJ=1,ACHSK=""
  1.  S:'$D(^ACHSSVR(ACHSEIN,0)) ^ACHSSVR(ACHSEIN,0)="999999^0"
  1. INDEXB ;
  1.  S ACHSJ=$O(^ACHSSVR(ACHSEIN,ACHSJ))
  1.  G INDEXZ:ACHSJ=""!(+ACHSJ=0)
  1. INDEXC ;
  1.  ;BEGIN Y2K BLOCK
  1.  S ACHSK=$O(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
  1.  G INDEXB:ACHSK=""!(+ACHSK=0)
  1.  S ACHSX=$G(^ACHSSVR(ACHSEIN,ACHSJ,ACHSK))
  1.  S ACHSPNAM=$E(ACHSX,103,118)
  1.  S:ACHSPNAM="" ACHSPNAM=" "
  1.  S ^ACHSSVR(ACHSEIN,"N",ACHSJ,ACHSPNAM,ACHSK)="",ACHSADT=$E(ACHSX,61,66)
  1.  S ACHSADT=$S($E(ACHSADT,1,2)<84:20000000,1:19000000)
  1.  S X=$P($G(^ACHSSVR(ACHSEIN,0)),U) ; XXX-0999-200030
  1.  S X=$S($E(X,1,2)<84:20000000,1:19000000)+X
  1.  S:ACHSADT<X $P(^ACHSSVR(ACHSEIN,0),U,1)=$E(ACHSADT,3,8) ; XXX-0999-200030
  1.  S X=$P($G(^ACHSSVR(ACHSEIN,0)),U,2) ; XXX-0999-200030
  1.  S X=$S($E(X,1,2)<84:20000000,1:19000000)+X
  1.  S:ACHSADT>X $P(^ACHSSVR(ACHSEIN,0),U,2)=$E(ACHSADT,3,8) ; XXX-0999-200030
  1.  ;END Y2K BLOCK
  1.  G INDEXC
  1.  ;
  1. INDEXZ ;
  1.  Q
  1.  ;