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

ACHSVDV2.m

Go to the documentation of this file. 
  1. ACHSVDV2 ; IHS/ITSC/TPF/PMF - YTD PAID VENDOR INFO BY FY ; 
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**15**;JUN 11, 2001
  1.  ;ACHS*3.1*15;IHS.OIT.FCJ MODIFIED FORMAT FOR DISPLAYING RATE AND CONTRACT NUMBER NEW LENGTH
  1.  ;
  1.  N ACHSIEN
  1.  S ACHSIEN=$O(^ACHSVPMT(DUZ(2),1,"B",ACHSPROV,0))
  1.  I 'ACHSIEN W !!,"None on file." Q
  1.  I '$D(^ACHSVPMT(DUZ(2),1,ACHSIEN,1,0)) W !!,"None on file." Q
  1.  ;
  1.  W !!,"FISCAL YEAR",?16,"A M O U N T",?30,"LAST PMT DATE",!!
  1.  F ACHS=0:0 S ACHS=$O(^ACHSVPMT(DUZ(2),1,ACHSIEN,1,ACHS)) Q:'ACHS  W ?2,ACHS,?14,"$",$J($FN($P(^(ACHS,0),U,2),",",2),12),?30,$$FMTE^XLFDT($P(^(0),U,3)),!
  1.  Q
  1.  ;
  1. AGRDSP ;EP
  1.  G:'$D(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSAGTP)) AGRNEW
  1.  D HDR
  1.  S R="",ACHSI=0
  1.  K ACHSAGRL
  1. AGRDSP1 ;
  1.  S R=$O(^AUTTVNDR(ACHSPROV,18,"AGR",ACHSAGTP,R))
  1.  G AGRDSPZ:+R=0
  1. A2A ;
  1.  S ACHSI=ACHSI+1,ACHSAGRL(ACHSI)=R
  1.  ;ACHS*3.1*15 IHS.OIT.FCJ REWROTE DISPLAY OF RATE #
  1.  ;W !,$J(ACHSI,2),?3,ACHSAGTP,?14,$E($P(^AUTTVNDR(ACHSPROV,18,R,0),U,1),1,2),$S(ACHSAGTP="BPA":"-A-",ACHSAGTP="PA":"-PA-",ACHSAGTP="RQ":"-R-",1:"")
  1.  W !,$J(ACHSI,2),?3,ACHSAGTP
  1.  I $L($P(^AUTTVNDR(ACHSPROV,18,R,0),U,1))>6 W ?8,$P(^(0),U) G A2C
  1.  E  W ?8,$E($P(^AUTTVNDR(ACHSPROV,18,R,0),U,1),1,2),$S(ACHSAGTP="BPA":"-A-",ACHSAGTP="PA":"-PA-",ACHSAGTP="RQ":"-R-",1:"")
  1.  S X=$E($P(^AUTTVNDR(ACHSPROV,18,R,0),U,1),3,6)
  1.  I ACHSAGTP="PA" W $E(X,2,4) G A2C
  1.  W $E(X,1,4)
  1. A2C ;
  1.  W ?27,$$MDY($P(^AUTTVNDR(ACHSPROV,18,R,0),U,8)),?36,$$MDY($P(^AUTTVNDR(ACHSPROV,18,R,0),U,9))
  1.  S X=$P(^AUTTVNDR(ACHSPROV,18,R,0),U,4)
  1.  I X="",($P(^AUTTVNDR(ACHSPROV,18,R,0),U,2)="") G A2D
  1.  S Y=$S(X="Y":"YES",X="N":" NO",1:"   ")
  1.  I Y="   ",($P(^AUTTVNDR(ACHSPROV,18,R,0),U,2)="") G A2D
  1.  S Y=Y_"  INP: "
  1.  S:$P(^AUTTVNDR(ACHSPROV,18,R,0),U,2)'="" Y=Y_$P(^(0),U,2)
  1.  W ?45,Y,!
  1. A2D ;
  1.  S X=$P(^AUTTVNDR(ACHSPROV,18,R,0),U,5)
  1.  I X="",($P(^AUTTVNDR(ACHSPROV,18,R,0),U,3)="") G A2E
  1.  S Y=$S(X="Y":"YES",X="N":" NO",1:"   ")
  1.  I Y="   ",($P(^AUTTVNDR(ACHSPROV,18,R,0),U,3)="") G A2E
  1.  S Y=Y_"  OUT: "
  1.  S:$P(^AUTTVNDR(ACHSPROV,18,R,0),U,3)'="" Y=Y_$P(^(0),U,3)
  1.  W ?45,Y,!
  1. A2E ;
  1.  W:$P(^AUTTVNDR(ACHSPROV,18,R,0),U,7)'="" ?49,"PRO: ",$P(^(0),U,7),!
  1.  G AGRDSP1
  1.  ;
  1. AGRDSPZ ;
  1.  Q:$D(ACHSRQFL)!$D(ACHSPAFL)!$D(ACHSBPFL)
  1. AGRSEL ;
  1.  S DA=""
  1.  S Y=$$DIR^XBDIR("NO^1:"_ACHSI,"Enter # to Edit","","","","",2)
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  I Y="" G AGRNEW
  1.  S DA=ACHSAGRL(+Y)
  1.  Q
  1.  ;
  1. AGRNEW ;ADD NEW AGREEMENT INFORMATION HERE
  1.  Q:'$D(^XUSEC("ACHSZMGR",DUZ))
  1.  S Y=$$DIR^XBDIR("Y","Want to enter a new Vendor "_$S(ACHSAGTP="RQ":"RATE QUOTATION",ACHSAGTP="PA":"PROVIDER AGREEMENT",ACHSAGTP="BPA":"BLANKET PURCHASE AGREEMENT",1:" "),"N","","","",2)
  1.  Q:$D(DTOUT)!$D(DUOUT)
  1.  I 'Y S DA="" W @IOF Q
  1.  S:'$D(^AUTTVNDR(ACHSPROV,18,0)) ^AUTTVNDR(ACHSPROV,18,0)=$$ZEROTH^ACHS(9999999.11,1801)
  1.  S DIC="^AUTTVNDR("_ACHSPROV_",18,",DIC(0)="QAZEML",DA(1)=ACHSPROV,DIC("W")="W ""    "",$P(^(0),U,10)"
  1.  D ^DIC
  1.  Q:+Y<1
  1.  S DA(1)=ACHSPROV,DA=+Y
  1.  W !
  1.  K DIE,DR
  1.  S DIE("NO^")="",DIE=DIC,DR=".11///^S X=ACHSAGTP;.02;.04;.03;.05;.07;.06;.08;.09"
  1.  D ^DIE
  1.  K DIE
  1.  D AGRDSP
  1.  Q
  1.  ;
  1. HDR ;
  1.  W !!," #",?3,"Type",?14,"Number",?27,"Eff-Date",?36,"Exp-Date",?45,"MCR",?49,"Description",!?3,"----",?8,"------------------",?27,"--------",?36,"--------",?45,"---",?49,"----------------------------"
  1.  Q
  1.  ;
  1. MDY(X) ;
  1.  Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
  1.  ;