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

ACHSSVRP.m

Go to the documentation of this file. 
  1. ACHSSVRP ; 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.  S (ACHSFAC,ACHSNMS,ACHSSEQ)="",(ACHSEIN,ACHSDCNT,ACHSPGNO)=0
  1.  S ACHSDATE=$$HTE^XLFDT($H)
  1. B1 ;
  1.  S ACHSEIN=$O(^ACHSSVR(ACHSEIN))
  1.  G PRTEND:+ACHSEIN=0
  1.  S DIC="^AUTTVNDR(",DIC(0)="",X=ACHSEIN,D="E"
  1.  D IX^DIC
  1.  I +Y<1 U IO(0) W "VENDOR LOOKUP ERROR FOR EIN # ",ACHSEIN U IO G B1
  1.  S ACHSEINP=+Y
  1.  I '$D(^ACHSSVR(ACHSEIN,"N")) D INDEX
  1.  D FAX,PGHDR
  1.  S ACHSFAC=""
  1. B2 ;
  1.  S ACHSFAC=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC))
  1.  G B1:+ACHSFAC=0
  1.  S ACHSNMS=""
  1. B3 ;
  1.  S ACHSNMS=$O(^ACHSSVR(ACHSEIN,"N",ACHSFAC,ACHSNMS))
  1.  G B2:ACHSNMS=""
  1.  S ACHSSEQ=""
  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" S ACHSFACN="UNKNOWN FAC CODE" U IO G B5
  1.  S ACHSFACN=$E($P($G(^DIC(4,+Y,0)),U),1,12)
  1. B5 ;
  1.  I $Y>55 D PGHDR
  1.  S X=ACHSX
  1.  W ACHSFACN,?14,$E($E(X,103,122),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),!?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 ; Print totals.
  1.  U ACHSPTR
  1.  W !,$$REPEAT^XLFSTR("-",70),!!?10,"TOTAL DOCUMENTS LISTED = ",ACHSDCNT
  1. ZEND ;
  1.  I $D(IO),IO D ^%ZISC
  1. ZENDA ;
  1.  K X,Y,ACHSEIN
  1.  Q
  1.  ;
  1. PGHDR ;
  1.  U ACHSPTR
  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 ; Print FAX cover sheet for vendor.
  1.  U ACHSPTR
  1.  W @IOF
  1.  F I=1:1:5 W !
  1.  W $$C^XBFUNC("INDIAN HEALTH SERVICE",80)
  1.  W !,$$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 ; Create print index for ^ACHSSVR & Begin & End date.
  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)+ACHSADT
  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)=$E(ACHSADT,3,8)
  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) ;
  1.  ;END Y2K BLOCK
  1.  G INDEXC
  1.  ;
  1. INDEXZ ;
  1.  Q
  1.  ;