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

ACHSA4.m

Go to the documentation of this file. 
  1. ACHSA4 ; IHS/ITSC/PMF - ENTER DOCUMENTS (5/8)-(CAN) ;    [ 02/01/2005  12:24 PM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,16**;JUN 11, 2001
  1.  ;ACHS*3.1*3  fix bug in reference to cost center
  1.  ;ACHS*3.1*16 Fixed problem w/CANS
  1.  ;
  1.  ;
  1.  S ACHSTV=$O(^ACHS("TEST VERSION","B","ACHSA4",""))
  1.  I ACHSTV'="" S ACHSTV=$G(^ACHS("TEST VERSION",ACHSTV,1)) I $P(ACHSTV,U,3) S ACHSTV=U_$P(ACHSTV,U,2) G @ACHSTV
  1.  ;
  1.  ;
  1.  ;COST CENTER CODES
  1.  S ACHS573=$O(^ACHS(1,"B",573,0))        ;CHS GM & S HOSPITALIZTION
  1.  S ACHS568=$O(^ACHS(1,"B",568,0))        ;DENTAL SERVICES
  1.  S ACHS574=$O(^ACHS(1,"B",574,0))        ;CHS AMBULATORY CARE
  1.  S ACHS575=$O(^ACHS(1,"B",575,0))        ;CHS ALL OTHER
  1.  S ACHSF638=$P($G(^ACHSF(DUZ(2),0)),U,8) ;'FACILITY IS 638 TYPE'
  1.  S ACHS533=$O(^ACHS(1,"B",533,0))        ;NOT DEFINED HERE
  1.  ;
  1.  I ACHS573,ACHS568,ACHS574 G A1
  1.  I ACHSF638="Y",$D(^ACHS(1,"B")) G A1
  1.  ;
  1.  W *7,!!,"CHS COST CENTER TABLE INCOMPLETE.",!
  1.  W:ACHSF638'="Y" !,"Must have Cost Centers 568, 573, and 574."
  1.  Q
  1.  ;
  1. A1 ;EP
  1.  W !!,"Enter last 4 digits of the CAN Number: "
  1.  I ACHSCAN,$D(^ACHS(2,ACHSCAN,0)) S ACHSCC=$P($G(^ACHS(2,ACHSCAN,0)),U,2) W $P($G(^ACHS(2,ACHSCAN,0)),U),"// "
  1.  D READ^ACHSFU
  1.  I $G(ACHSQUIT) D END^ACHSA Q
  1.  G A3^ACHSA:$D(DUOUT)    ;GO BACK TO ?   PROMPT
  1.  I Y?1"?".E G A2
  1.  I Y="" G ACHK:ACHSCAN]"" W *7,"  Must Have CAN Number" G A1
  1.  I $D(DTOUT) G A3^ACHSA
  1.  I $L(Y)'=4 W *7,"  ??" G A1
  1.  ;
  1.  ;GET  'AREA'
  1.  S Y=$P($G(^AUTTAREA($P($G(^AUTTLOC(DUZ(2),0)),U,4),0)),U,4)_Y
  1.  ;
  1.  W "     ",Y
  1.  ;
  1.  ;
  1.  S N=$O(^ACHS(2,"B",Y,""))
  1.  I N,$D(^ACHS(2,N,0)),$S('+$P($G(^ACHS(2,N,0)),U,4):1,1:+$P($G(^ACHS(2,N,0)),U,4)>DT) S ACHSCAN=N,ACHSCC=$P($G(^ACHS(2,N,0)),U,2) G ACHK
  1.  W *7,"  ??",!!
  1.  I +N,$D(^ACHS(2,N,0)),$P($G(^ACHS(2,N,0)),U,4)]"",$P($G(^ACHS(2,N,0)),U,4)<DT W !?20,"CAN ",Y," EXPIRED ",$$FMTE^XLFDT($P($G(^ACHS(2,N,0)),U,4)),".",!?21," PLEASE SELECT ANOTHER CAN!" W !!
  1.  G A1
  1.  ;
  1. A2 ;
  1.  ;beginning Y2K fix
  1.  I $$PARM^ACHS(2,24)'="Y"!($D(^XUSEC("ACHSZMGR",DUZ))) G ALLCAN
  1.  ;BEGIN Y2K FIX BLOCK 2;CS;2990525
  1.  K ACHS("FY") S R="" F  S R=$O(^ACHS(2,"FY",DUZ(2),R)) Q:R=""  S ACHS("FY",R+$S(R'<1000:0,R<84:2000,1:1900))=R ;Y2000
  1.  ;END Y2K FIX BLOCK 2
  1.  ;S R="",ACHS=0 ;Y2000
  1.  S (OLDR,R)="",ACHS=0 ;Y2000
  1. A3 ;
  1.  ;Y2000 Changes are required to R and $E(ACHSCFY,3,4)
  1.  ;Y2000 I think that the sliding window approach is best here
  1.  ;Y2000 The variable R appears to be local this this piece of code
  1.  ;S R=$O(^ACHS(2,"FY",DUZ(2),R)) ;Y2000
  1.  ;Y2000 Because of the reentrant nature of this section the following
  1.  ;Y2000 goof-age is required, otherwise I would be facing a major rewrite
  1.  S R=OLDR,R=$O(ACHS("FY",R)),OLDR=R ;Y2000
  1.  G AEND:R=""
  1.  I R>ACHSCFY G A3 ;Y2000
  1.  I R<(ACHSCFY-1) G A3 ;Y2000
  1.  S R=ACHS("FY",R) ;Y2000
  1.  ;end Y2K fix block
  1.  S ACHSRR=0
  1. A3A ;
  1.  S ACHSRR=$O(^ACHS(2,"FY",DUZ(2),R,ACHSRR))
  1.  G A3:ACHSRR=""
  1.  ;if facility does not match, go for next EIN (A3A), not next year (A3)
  1.  G:$P($G(^ACHS(2,ACHSRR,0)),U,3)'=DUZ(2) A3A I $P($G(^ACHS(2,ACHSRR,0)),U,4)]"",$P($G(^ACHS(2,ACHSRR,0)),U,4)<DT G A3A
  1.  S ACHSRRR=0
  1. A3B ;
  1.  S ACHSRRR=$O(^ACHS(2,"FY",DUZ(2),R,ACHSRR,ACHSRRR))
  1.  G A3A:ACHSRRR=""
  1.  I '$D(^ACHS(2,ACHSRR,1,ACHSRRR,0)) G A3B
  1.  S ACHSCNFY=R,ACHSCANZ=$P($G(^ACHS(2,ACHSRR,0)),U)
  1.  G:ACHSF638="Y" CANDSP
  1.  S ACHSAQ=$P($G(^ACHS(2,ACHSRR,0)),U,2)
  1.  G:ACHSTYP'=1 A4
  1.  I ACHSAQ=ACHS573!(ACHSAQ=ACHS575)!(ACHSAQ=ACHS533) G CANDSP
  1.  G A3B
  1.  ;
  1. A4 ;
  1.  G A8:ACHSTYP=3,CANDSP:ACHSAQ=ACHS568,A3B
  1. A8 ;
  1.  I ACHSAQ=ACHS568 G A3B
  1. CANDSP ;
  1.  S ACHS=ACHS+1,ACHS(ACHS)=ACHSRR_"^"_ACHSRRR
  1.  I ACHS=1 D HDR
  1.  W !,$J(ACHS,5),?10,ACHSCNFY,?15,ACHSCANZ
  1.  I $P($G(^ACHS(2,ACHSRR,0)),U,2)'="" W ?30,$P($G(^ACHS(1,$P($G(^ACHS(2,ACHSRR,0)),U,2),0)),U,2)
  1.  I '(ACHS#15),'$$DIR^XBDIR("E") S R="" G AEND
  1.  G A3B
  1.  ;
  1.  ;
  1. AEND ;
  1.  I ACHS=0 W *7,!!,"There are no CHS COMMON ACCOUNTING NUMBERs for this facility.",!!,"Please contact your Site Manager.",!,*7 G A1
  1.  S Y=$$DIR^XBDIR("N^1:"_ACHS,"ENTER ITEM # FOR CAN NUMBER ","","","","^W !,""Enter the number next to the CAN you want for this P.O.""",1)
  1.  G A1:$D(DUOUT),END^ACHSA:$D(DIRUT)
  1.  S ACHSCAN=$P(ACHS(+Y),U,1)
  1.  G A1
  1.  ;
  1. ACHK ;EP.
  1.  S %=$E($P($G(^ACHS(2,ACHSCAN,0)),U),5)        ;CAN NUMBER
  1.  I %="O" W *7,!?5,"'O' CANs are not authorized." G A1
  1.  ;beginning Y2K fix
  1.  ;Y2000 The following code appears to be OK as is
  1.  ;I "MNPJK"[% D  I % G A1       ;ACHS*3.1*16 10/1/2009   IHS/OIT/FCJ REMOVED TEST FOR 2 YR CAN'S.
  1.  ;. S %=$S(((%="M")&(ACHSACFY'=1993)):1,((%="N")&(ACHSACFY'=1994)):1,((%="P")&(ACHSACFY'=1995)):1,((%="J")&(ACHSACFY'=1996)):1,((%="K")&(ACHSACFY'=1997)):1,1:%)
  1.  ;. I % W *7,!?5,"CAN '",$P($G(^ACHS(2,ACHSCAN,0)),U),"' is invalid for FY '",ACHSACFY,"'." Q
  1.  ;. S %=$$FY^ACHSVAR($A(%)+22-$S(%="P":7,%="M":6,%="N":6,1:0))
  1.  ;. S %=$S(ACHSEDOS<$P(%,U):1,ACHSEDOS>($P(%,U,2)+10000):2,1:0)
  1.  ;. I % W *7,!?5,"Date Of Service ",$S(%=1:"BEFORE",1:"AFTER")," 2-year CAN's authority."
  1.  ;.Q
  1.  ;end Y2K fix block
  1.  S ACHSCNFY=0
  1.  I DUZ(2)'=+$P($G(^ACHS(2,ACHSCAN,0)),U,3) W *7,"  CAN # NOT FOR THIS FACILITY" G A1
  1.  S (ACHSAQ,ACHSCC)=$P($G(^ACHS(2,ACHSCAN,0)),U,2)
  1.  G ACHKA:ACHSF638="Y",ACHKA:ACHSTYP'=2,ACHKA:ACHSAQ=ACHS568
  1.  W !!,*7," CAN # NOT VALID FOR DOCUMENT TYPE"
  1.  G A1
  1.  ;
  1. ACHKA ;
  1.  I '$O(^ACHS(2,ACHSCAN,1,0)) G ACHKB
  1.  S %=0
  1.  F  S %=$O(^ACHS(2,ACHSCAN,1,%)) Q:'%  I $G(^ACHS(2,ACHSCAN,1,%,0))=$E(ACHSACFY,1,4)!($G(^ACHS(2,ACHSCAN,0))=$E(ACHSCFY,3,4)) G ACHKB
  1.  W *7,!,"  CAN # CANNOT BE USED FOR THIS FISCAL YEAR."
  1.  G A1
  1.  ;
  1. ACHKB ;
  1.  I '$P($G(^ACHS(2,ACHSCAN,0)),U,4)!($P($G(^ACHS(2,ACHSCAN,0)),U,4)>DT) G ACHK1
  1.  W *7,!,"  CAN # HAS EXPIRED AND CANNOT BE USED"
  1.  G A1
  1.  ;
  1. ACHK1 ;
  1.  I ACHSTYP'=1 G ACHK2
  1.  S ACHSSCC=""
  1.  I $D(^ACHS(3,DUZ(2),1,"B","252G"))&(ACHSAQ=ACHS573)!(ACHSAQ=ACHS533) S ACHSSCC=+$O(^ACHS(3,DUZ(2),1,"B","252G",0))
  1.  I ACHSF638="Y" G ACHK2:ACHSAQ=$O(^ACHS(1,"B",873,0)),ACHK2:ACHSAQ=$O(^ACHS(1,"B",875,0))
  1.  I ACHSAQ=ACHS573!(ACHSAQ=ACHS575)!(ACHSAQ=ACHS533) G ACHK2
  1.  W !!,*7," NOT VALID CAN NUMBER FOR HSA-43"
  1.  G A1
  1.  ;
  1. ACHK2 ;
  1.  G ^ACHSA5
  1.  ;
  1. ALLCAN ;
  1.  ;beginning Y2k fix
  1.  S ACHSR1="",ACHS=0
  1. ALL1 ;
  1.  S ACHSR1=$O(^ACHS(2,"B",ACHSR1))
  1.  I ACHSR1="" S R="" G AEND
  1.  S ACHSRR1=0,ACHSRR1=$O(^ACHS(2,"B",ACHSR1,ACHSRR1))
  1.  G:$P($G(^ACHS(2,ACHSRR1,0)),U,3)'=DUZ(2) ALL1
  1.  I $P($G(^ACHS(2,ACHSRR1,0)),U,4)]"",$P($G(^ACHS(2,ACHSRR1,0)),U,4)<DT G ALL1
  1.  S ACHSCNFY="",ACHSCANZ=$P($G(^ACHS(2,ACHSRR1,0)),U)
  1.  I '$D(^ACHS(2,ACHSRR1,1,0)) G ALL1B
  1.  S ACHSRRR1=""
  1. ALL1A ;
  1.  S ACHSRRR1=$O(^ACHS(2,ACHSRR1,1,ACHSRRR1))
  1.  G:ACHSRRR1="" ALL1 G:ACHSRRR1=0 ALL1A
  1.  S ACHSCNFY=$P($G(^ACHS(2,ACHSRR1,1,ACHSRRR1,0)),U)
  1.  G:ACHSCNFY="" ALL1A
  1.  ;Y2000 The following line will fail in 2000
  1.  ;I ACHSCNFY>$E(ACHSCFY,3,4) G ALL1A
  1.  ;Y2000 This is a predy bogus way to deal with this but if not
  1.  ;Y2000 done like this it would be a major rewrite.
  1.  S:$L(ACHSCNFY)<4 ACHSCNFY=ACHSCNFY+$S(ACHSCNFY<84:2000,1:1900)
  1.  I ACHSCNFY>ACHSCFY G ALL1A
  1.  S ACHSCNFY=$E(ACHSCNFY,3,4)
  1.  ;end Y2k fix block
  1. ALL1B ;
  1.  G:ACHSF638="Y" CANDSP1
  1.  S ACHSAQ=$P($G(^ACHS(2,ACHSRR1,0)),U,2)
  1.  G:ACHSTYP'=1 ALL2
  1.  I ACHSAQ=ACHS573!(ACHSAQ=ACHS575)!(ACHSAQ=ACHS533) G CANDSP1
  1.  G ALL1
  1.  ;
  1. ALL2 ;
  1.  G ALL3:ACHSTYP=3,CANDSP1:ACHSAQ=ACHS568,ALL1
  1. ALL3 ;
  1.  I ACHSAQ=ACHS568 G ALL1
  1. CANDSP1 ;
  1.  S ACHS=ACHS+1,ACHS(ACHS)=ACHSRR1
  1.  I ACHS=1 D HDR
  1.  W !,$J(ACHS,5),?10,ACHSCNFY,?15,ACHSCANZ
  1.  ;
  1.  ;ACHS*31.*3  2/11/02  pmf  don't reference local array, reference global
  1.  ;I $P($G(ACHS(2,ACHSRR1,0)),U,2)'="" W ?30,$P($G(^ACHS(1,$P($G(^ACHS(2,ACHSRR1,0)),U,2),0)),U,2)  ; ACHS*3.1*3
  1.  I $P($G(^ACHS(2,ACHSRR1,0)),U,2)'="" W ?30,$P($G(^ACHS(1,$P($G(^ACHS(2,ACHSRR1,0)),U,2),0)),U,2)  ; ACHS*3.1*3
  1.  ;
  1.  I '(ACHS#15),'$$DIR^XBDIR("E") S R="" G AEND
  1.  I '$D(^ACHS(2,ACHSRR1,1,0)) G ALL1
  1.  G ALL1A
  1.  ;
  1. HDR ;
  1.  W !!,"ITEM #",?10,"FY",?15,"CAN NUMBER",?30,"DESCRIPTION OF THE CAN NUMBER",!,"------",?10,"--",?15,"----------",?30,"-----------------------------"
  1.  Q
  1.  ;
  1. GTH ;
  1.  S DIC="^ACHS(2,"
  1.  S DIC(0)="AEMQ"
  1.  D ^DIC
  1.  Q