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