ACHSFU.m

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