ACHSFU ; IHS/ITSC/PMF - CHS STANDARD SUB-ROUTINES ; [ 03/25/2003 12:28 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - FYCVT no future FY.
;8/23/00 ... PMF year fix to tag FYCVT
;
BM ;EP
S ACHSBM=IOSL-10
I '$D(IO("S")),$D(ACHSIO),ACHSIO=IO S ACHSBM=IOSL-4
Q
;
DIRD ;EP
I X="@" W " DELETED!" S Y=""
Q
;
FYCVT ;EP
;8/23/00 ... PMF adjusted to handle future years
I ACHSX>$E(ACHSCFY,4) S ACHSY=((+$E(ACHSCFY,1,3)-1)_"0")+ACHSX Q ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
S ACHSY=($E(ACHSCFY,1,3)_"0")+ACHSX ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
Q ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
;
;input:
;ACHSX - the last digit of the fiscal year we want to use
;ACHSCFY - the current fiscal year
;output:
;ACHSY - the fiscal year to use expressed as 4 digits
S ACHSY=($E(ACHSCFY,1,3)_"0")+ACHSX
;the fiscal year to use cannot be more than 7 years ago or more
;than 1 year ahead
I ACHSY+7<ACHSCFY S ACHSY=ACHSY+10
I ACHSCFY+1<ACHSY S ACHSY=ACHSY-10
Q
;
LINES ;EP
S ACHS("-")=$$REPEAT^XLFSTR("-",79),ACHS("=")=$$REPEAT^XLFSTR("=",79),ACHS("*")=$$REPEAT^XLFSTR("*",79)
Q
;
PRMT(T,V,L) ;EP - T = TAB; V= VAR; L = LENGTH
S T=$G(T),V=$G(V),L=$G(L)
Q $$REPEAT^XLFSTR(" ",T+1)_$S($L(V):$$REPEAT^XLFSTR(" ",$L(V)+3),1:"")_"|"_$$REPEAT^XLFSTR("-",L)_"|"
;
READ ;EP
K DTOUT,DUOUT,ACHSQUIT
N ACHSDOIT
S ACHSDOIT="R"_" Y:"_DTIME
X ACHSDOIT
I '$T S (DTOUT,Y)=""
S:Y="/.," DTOUT=""
S:Y="^" (DUOUT,Y)=""
I $D(DTOUT)!$D(DUOUT) S ACHSQUIT=1
Q
;
KILL ;EP
K ACHSBAL,ACHSBLT,ACHSDCR,ACHSCC,ACHSERR,ACHSPATF,ACHSFML,ACHSACFY,ACHSCFY,ACHSFYWK,ACHSHRN,ACHS,ACHSDES,ACHSREFT,ACHSUCI,ACHSACN,ACHSACO,ACHSTAO
K ACHSARCO,ACHSOPAY,ACHSDEST,ACHSQUIT,ACHSSIG,ACHSSLOC,ACHSX,ACHSY,ACHSTIEN,ACHSACWK,ACHSSVDT,ACHSWKLD,ACHSCT,DRENT,ACHSLCA,LS,ZTSK
K DA,ACHSRR,ACHSPAMT,ACHSF638,DFN,X1,ACHSXY,X,X2,ACHSGCHK,ACHSFYDT
K ACHSRT,ACHSI,ACHSJ,ACHSCTNA,ACHSAGRN
K ^ACHSUSE($J)
D ^ACHSKILL
Q
;
SB1 ;EP
W !!?10,"The Following are Valid Fiscal Years",!
F ACHS=0:0 S ACHS=$O(ACHSFYWK(DUZ(2),ACHS)) Q:'ACHS W !?20,ACHS
Q
;
SLV ;EP
;SET OPEN AND CLOSE FOR SLAVE DEVICE
K ACHSPPO,ACHSPPC
S ACHSPPO=$P(^%ZIS(2,IO("S"),10),U) ;OPEN PARM
S ACHSPPC=$P(^%ZIS(2,IO("S"),11),U) ;CLOSE PARM
I ('$L(ACHSPPO))!('$L(ACHSPPC)) K ACHSPPO,ACHSPPC Q
X ACHSPPC
Q
;
;CHECK TO SEE IF OBLIGATION LIMIT IS EXCEEDED FOR THIS TYPE DOC.
OBLM ;EP
K DUOUT
;
;we are testing the amount of the supplement or the adjustment.
;figure out which one.
N AMT
S AMT=$G(ACHSADAM)
I AMT="" S AMT=$G(ACHSPDAT)
;
;9/11/01 pmf add next line to get the right number during EOBR
; processing
I $D(ACHSISAO) S AMT=Y
I AMT="" Q
;
I '$D(^ACHSF(DUZ(2),"N",ACHSTYP,0)) Q
;
;NO OBLIG. LIMITS ;PER MARIA WE DON'T CARE ABOUT THIS LIMIT IT
;SHOULD POST REGARDLESS- SEE E-MAIL 10/2/00 /fiscal/financial
;issues/adjustments to paid documents
;
N X
S X=$P($G(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,3)
;
I AMT>X D
. I $D(ACHSISAO) S ACHSERRE=34 Q
. W !!,*7,"The OBLIGATION LIMIT for this type of document is "
. D FMT^ACHS
. W ".",!!,"Enter a lesser amount of money or exit the document.",!!
. W:0 "" ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
.S DUOUT=""
;
Q
;
BRPT ;EP
I $D(ACHSQIO) S:$L($P(ACHSQIO,U,2)) %ZIS("IOPAR")=$P(ACHSQIO,U,2),ACHSQIO=$P(ACHSQIO,U,1) F S IOP=ACHSQIO D ^%ZIS Q:'POP H 30
D BM,LINES,NOW^ACHS
S ACHSTIME=$$C^XBFUNC(ACHSTIME,80),ACHSLOC=$$C^XBFUNC($$LOC^ACHS,80),ACHSPG=0,ACHSUSR=$$USR^ACHS
U IO
Q
;
;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
638() ;EP - 638 menu control.
I $P(^ACHSF(DUZ(2),0),U,8)="Y" Q 1
S XQUIT=""
W !,"FACILITY IS NOT 638 FACILITY",!
Q 0
;
;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
ACHSFU ; IHS/ITSC/PMF - CHS STANDARD SUB-ROUTINES ; [ 03/25/2003 12:28 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5**;JUN 11, 2001
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 - FYCVT no future FY.
+3 ;8/23/00 ... PMF year fix to tag FYCVT
+4 ;
BM ;EP
+1 SET ACHSBM=IOSL-10
+2 IF '$DATA(IO("S"))
IF $DATA(ACHSIO)
IF ACHSIO=IO
SET ACHSBM=IOSL-4
+3 QUIT
+4 ;
DIRD ;EP
+1 IF X="@"
WRITE " DELETED!"
SET Y=""
+2 QUIT
+3 ;
FYCVT ;EP
+1 ;8/23/00 ... PMF adjusted to handle future years
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF ACHSX>$EXTRACT(ACHSCFY,4)
SET ACHSY=((+$EXTRACT(ACHSCFY,1,3)-1)_"0")+ACHSX
QUIT
+3 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
SET ACHSY=($EXTRACT(ACHSCFY,1,3)_"0")+ACHSX
+4 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
QUIT
+5 ;
+6 ;input:
+7 ;ACHSX - the last digit of the fiscal year we want to use
+8 ;ACHSCFY - the current fiscal year
+9 ;output:
+10 ;ACHSY - the fiscal year to use expressed as 4 digits
+11 SET ACHSY=($EXTRACT(ACHSCFY,1,3)_"0")+ACHSX
+12 ;the fiscal year to use cannot be more than 7 years ago or more
+13 ;than 1 year ahead
+14 IF ACHSY+7<ACHSCFY
SET ACHSY=ACHSY+10
+15 IF ACHSCFY+1<ACHSY
SET ACHSY=ACHSY-10
+16 QUIT
+17 ;
LINES ;EP
+1 SET ACHS("-")=$$REPEAT^XLFSTR("-",79)
SET ACHS("=")=$$REPEAT^XLFSTR("=",79)
SET ACHS("*")=$$REPEAT^XLFSTR("*",79)
+2 QUIT
+3 ;
PRMT(T,V,L) ;EP - T = TAB; V= VAR; L = LENGTH
+1 SET T=$GET(T)
SET V=$GET(V)
SET L=$GET(L)
+2 QUIT $$REPEAT^XLFSTR(" ",T+1)_$SELECT($LENGTH(V):$$REPEAT^XLFSTR(" ",$LENGTH(V)+3),1:"")_"|"_$$REPEAT^XLFSTR("-",L)_"|"
+3 ;
READ ;EP
+1 KILL DTOUT,DUOUT,ACHSQUIT
+2 NEW ACHSDOIT
+3 SET ACHSDOIT="R"_" Y:"_DTIME
+4 XECUTE ACHSDOIT
+5 IF '$TEST
SET (DTOUT,Y)=""
+6 IF Y="/.,"
SET DTOUT=""
+7 IF Y="^"
SET (DUOUT,Y)=""
+8 IF $DATA(DTOUT)!$DATA(DUOUT)
SET ACHSQUIT=1
+9 QUIT
+10 ;
KILL ;EP
+1 KILL ACHSBAL,ACHSBLT,ACHSDCR,ACHSCC,ACHSERR,ACHSPATF,ACHSFML,ACHSACFY,ACHSCFY,ACHSFYWK,ACHSHRN,ACHS,ACHSDES,ACHSREFT,ACHSUCI,ACHSACN,ACHSACO,ACHSTAO
+2 KILL ACHSARCO,ACHSOPAY,ACHSDEST,ACHSQUIT,ACHSSIG,ACHSSLOC,ACHSX,ACHSY,ACHSTIEN,ACHSACWK,ACHSSVDT,ACHSWKLD,ACHSCT,DRENT,ACHSLCA,LS,ZTSK
+3 KILL DA,ACHSRR,ACHSPAMT,ACHSF638,DFN,X1,ACHSXY,X,X2,ACHSGCHK,ACHSFYDT
+4 KILL ACHSRT,ACHSI,ACHSJ,ACHSCTNA,ACHSAGRN
+5 KILL ^ACHSUSE($JOB)
+6 DO ^ACHSKILL
+7 QUIT
+8 ;
SB1 ;EP
+1 WRITE !!?10,"The Following are Valid Fiscal Years",!
+2 FOR ACHS=0:0
SET ACHS=$ORDER(ACHSFYWK(DUZ(2),ACHS))
IF 'ACHS
QUIT
WRITE !?20,ACHS
+3 QUIT
+4 ;
SLV ;EP
+1 ;SET OPEN AND CLOSE FOR SLAVE DEVICE
+2 KILL ACHSPPO,ACHSPPC
+3 ;OPEN PARM
SET ACHSPPO=$PIECE(^%ZIS(2,IO("S"),10),U)
+4 ;CLOSE PARM
SET ACHSPPC=$PIECE(^%ZIS(2,IO("S"),11),U)
+5 IF ('$LENGTH(ACHSPPO))!('$LENGTH(ACHSPPC))
KILL ACHSPPO,ACHSPPC
QUIT
+6 XECUTE ACHSPPC
+7 QUIT
+8 ;
+9 ;CHECK TO SEE IF OBLIGATION LIMIT IS EXCEEDED FOR THIS TYPE DOC.
OBLM ;EP
+1 KILL DUOUT
+2 ;
+3 ;we are testing the amount of the supplement or the adjustment.
+4 ;figure out which one.
+5 NEW AMT
+6 SET AMT=$GET(ACHSADAM)
+7 IF AMT=""
SET AMT=$GET(ACHSPDAT)
+8 ;
+9 ;9/11/01 pmf add next line to get the right number during EOBR
+10 ; processing
+11 IF $DATA(ACHSISAO)
SET AMT=Y
+12 IF AMT=""
QUIT
+13 ;
+14 IF '$DATA(^ACHSF(DUZ(2),"N",ACHSTYP,0))
QUIT
+15 ;
+16 ;NO OBLIG. LIMITS ;PER MARIA WE DON'T CARE ABOUT THIS LIMIT IT
+17 ;SHOULD POST REGARDLESS- SEE E-MAIL 10/2/00 /fiscal/financial
+18 ;issues/adjustments to paid documents
+19 ;
+20 NEW X
+21 SET X=$PIECE($GET(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,3)
+22 ;
+23 IF AMT>X
Begin DoDot:1
+24 IF $DATA(ACHSISAO)
SET ACHSERRE=34
QUIT
+25 WRITE !!,*7,"The OBLIGATION LIMIT for this type of document is "
+26 DO FMT^ACHS
+27 WRITE ".",!!,"Enter a lesser amount of money or exit the document.",!!
+28 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF 0
WRITE ""
+29 SET DUOUT=""
End DoDot:1
+30 ;
+31 QUIT
+32 ;
BRPT ;EP
+1 IF $DATA(ACHSQIO)
IF $LENGTH($PIECE(ACHSQIO,U,2))
SET %ZIS("IOPAR")=$PIECE(ACHSQIO,U,2)
SET ACHSQIO=$PIECE(ACHSQIO,U,1)
FOR
SET IOP=ACHSQIO
DO ^%ZIS
IF 'POP
QUIT
HANG 30
+2 DO BM
DO LINES
DO NOW^ACHS
+3 SET ACHSTIME=$$C^XBFUNC(ACHSTIME,80)
SET ACHSLOC=$$C^XBFUNC($$LOC^ACHS,80)
SET ACHSPG=0
SET ACHSUSR=$$USR^ACHS
+4 USE IO
+5 QUIT
+6 ;
+7 ;Begin New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
638() ;EP - 638 menu control.
+1 IF $PIECE(^ACHSF(DUZ(2),0),U,8)="Y"
QUIT 1
+2 SET XQUIT=""
+3 WRITE !,"FACILITY IS NOT 638 FACILITY",!
+4 QUIT 0
+5 ;
+6 ;End New Code;IHS/SET/GTH ACHS*3.1*5 12/06/2002
