ACHSVAR ; IHS/ITSC/TPF/PMF - VARIABLES, OPTIONS ; [ 06/15/2001 8:10 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22,23,26**;JUN 11, 2001;Build 43
;ACHS*3.1*18 7/16/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
;
;this routine sets up certain basic vars for use in chs
;expected input: DUZ array
; U
; DT
;
;a partial list of the output:
;ACHSACFY the Active Current FY
;ACHSCFY the Current FY
;ACHSERR error flag default to off
;ACHSFC
;ACHSFYDT the start of the nbext FY, i.e, 3001001
;ACHSFYWK the workbook
;
;
I $D(^ACHSUSE("EOBR")) D Q:$D(XQUIT)
. S XQUIT=""
. W @IOF,!!!,*7,*7
. W $$C^XBFUNC("The global flag indicates EOBRs Are Now Being Processed"),!
. I '$D(^XUSEC("ACHSZMGR",DUZ)) W $$C^XBFUNC("Please Try Later"),!!!!!! D RTRN^ACHS Q
. S Y=$$DIR^XBDIR("Y","Do you want to delete the global flag and continue","N","","","^W !!,""You must enter 'Y' to delete the global flag, and provide access.""",1)
. Q:$D(DIRUT)!('Y)
. I Y D
.. S XQUIT="" F S XQUIT=$O(^ACHSUSE(XQUIT)) Q:XQUIT="" K ^ACHSUSE(XQUIT)
.. K XQUIT
.. Q
. Q
;
;ACHS*3.1*16 IHS.OIT.FCJ MODIFIED NXT LINE BECAUSE OF LENGTH
;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR AREA VAR
;{ABK,7/16/10}I '$D(^ACHSF(DUZ(2),2)) D NOTSET("Node 2 of the 'CHS FACILITY' file is missing for this facility '$D(^ACHSF("_DUZ(2)_",2)). Editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Deferred Services menu.")
I '$G(ACHSISAO),'$D(^ACHSF(DUZ(2),2)) D NOTSET("Node 2 of the 'CHS FACILITY' file is missing for this facility '$D(^ACHSF("_DUZ(2)_",2)). Editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Unmet Need menu.")
;
;5/29/01 pmf add check for ISAO
I $G(ACHSISAO) I $P($G(^ACHSAOP(DUZ(2),2)),U)="" D NOTSET("The 'EOBR IMPORT/SPLITOUT EXPORT' field of the 'CHS AREA OFFICE PARAMETERS' file must contain a directory pathname $P(^ACHSAOP("_DUZ(2)_",2),U)=NULL")
;
;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR AREA VAR
D:'$G(ACHSISAO) OPTS
I '$D(ACHSY) G END
K ACHSY,ACHSCHSS
D ^ACHSUF
I $G(ACHSERR)=1 S XQUIT=1 G END
D VIDEO^ACHS
I $P($G(^AUTTLOC(DUZ(2),0)),U,4)'="" D
.I $E(($P($G(^AUTTAREA(($P(^AUTTLOC(DUZ(2),0),U,4)),0)),U,4)))'="J" D CANZ
Q
;
END ;
W *7
I $$DIR^XBDIR("E","Press RETURN...","","","","",2)
S ACHSXQT=1
Q
;
OPTS ;
;
S ACHSY=""
F ACHS=2:1 Q:'$D(^DD(9002080,"GL",2,ACHS)) S ACHSY=$P($G(^ACHSF(DUZ(2),2)),U,ACHS)_ACHSY
I ACHSY]"" Q
D NOTSET("CHS Facility parameters not set")
Q
;
NOTSET(ACHSMSG) ;
D VIDEO^ACHS
W !!,*7,"The " W $G(IORVON) W "DENIAL" W $G(IORVOFF) W " parameters for this site have "
W $G(IORVON) W "not been properly set." W $G(IORVOFF)
W !!,$$C^ACHS(ACHSMSG)
W !!,"Print this screen to a printer."
W *7,!!,$G(IOBON),$G(IORVON),"Contact your site manager immediately!",$G(IOBOFF),$G(IORVOFF)
W !!,"Press RETURN..."
D READ^ACHSFU S ACHS("NOTSET")="",ACHSXQT=1
Q
;
CANZ ;
S ACHSXARA=$P($G(^AUTTLOC(DUZ(2),0)),U,4)
I ACHSXARA'="" S ACHSXPFX=$P($G(^AUTTAREA(ACHSXARA,0)),U,4),XCODE=$E(ACHSXPFX,1)
E S (ACHSXPFX,XCODE)=""
G CAN2:XCODE="J"
W *7,!!,"CAN NUMBER PREFIXES ARE BEING PROCESSED.........."
D WAIT^DICD
F R=0:0 S R=$O(^ACHS(2,R)) W "." Q:'R I $P($G(^ACHS(2,R,0)),U,3)=DUZ(2) D
. S ACHSXX=$P($G(^ACHS(2,R,0)),U),ACHSX3=$E(ACHSXX,1,3),ACHSX4=$E(ACHSXX,4,7) K ^ACHS(2,"B",ACHSXX,R) S ACHSX3="J"_$E(ACHSX3,2,3)
. S $P(^ACHS(2,R,0),U)=ACHSX3_ACHSX4,^ACHS(2,"B",ACHSX3_ACHSX4,R)=""
.Q
S $P(^AUTTAREA(ACHSXARA,0),U,4)="J"_$E(ACHSXPFX,2,3)
CAN2 ;
K R,X,ACHSXARA,ACHSXPFX,XCODE,ACHSXX,ACHSX3,ACHSX4
Q
;
MGR ;EP - If options not set, user has mgr key, enter the options.
I '$D(^XUSEC("ACHSZMGR",DUZ)) Q
S ACHSSITE=$P($G(^DIC(4,DUZ(2),0)),U)
D OPTIONS
K ACHSSITE
I $D(^ACHSF(DUZ(2),2)),$L(^(2)) S ACHSY=""
Q
;
OPTIONS ;
N DA,DIC,DIE,DR,DLAYGO
W !!!,"Edit the CHS facility options for '",ACHSSITE,"'.",!!,"1 question mark (""?"") will get you help.",!!,"2 question marks (""??"") usually gets you more help.",!!
W "For printed help, print out chapter 1 of the Tech Manual (D ^ACHSTM).",!
;ACHS*3.1*16 11.12.2009 IHS.OIT.FCJ ADDED DUNS TO NXT LINE;ACHS*3.1*23 REM EOBR PRINT;3.1*26-ADD FILE DIRECTORY
S DIE="^ACHSF(",DR="11.03;11.05:14.08;14.11:14.13;14.15:14.18;14.2;14.22;14.24:14.27;14.31;.05",DA=DUZ(2)
D ^DIE
Q:$P($G(^ACHSF(DUZ(2),0)),U,8)'="Y" ; Quit if not a 638 facility.
S DR="11.04;14.09"
D ^DIE
I $P($G(^ACHSF(DUZ(2),0)),U,6),$P($G(^(0)),U,7) Q
W *7,!!,"THE NEXT 2 PARAMETERS DETERMINE WHEN YOUR FISCAL YEAR STARTS.",!!,"IF YOU HAVE ANY DOUBTS ABOUT HOW TO ANSWER THE QUESTIONS, PLEASE CALL",!!,"DSD AT 999-999-9999 AND ASK FOR THE CHS DEVELOPER.",!
S DR="11.01;11.02"
D ^DIE
Q
;
FY(%) ;EP - Given a FY, return beg/end dates.
N X,Y
S X=$P($G(^ACHSF(DUZ(2),0)),U,6),Y=+$P($G(^(0)),U,7)
S %=$S(%>50:2,1:3)_%-Y
S X=%_X
S %=$E(X,1,3)
S Y=%+$S($E(X,4,7)="0101":0,1:1) ; Year
S %=$E(X,4,5) I $E(X,6,7)="01" S %=%-1 I '% S %=12
S %="0"_%,%=$E(%,$L(%)-1,$L(%)) ; Month
S Y=$E(Y,1,3)_%_$P("31^28^31^30^31^30^31^31^30^31^30^31",U,%) ; Day
I $E(Y,4,5)="02",'((1700+$E(Y,1,3))#4) S Y=$E(Y,1,5)_"29"
I $E(X,4,5)=$E(Y,4,5) S %=$E(X,6,7),%=%-1,%="0"_%,%=$E(%,$L(%)-1,$L(%)),Y=$E(Y,1,5)_%
Q X_U_Y
;
ACHSVAR ; IHS/ITSC/TPF/PMF - VARIABLES, OPTIONS ; [ 06/15/2001 8:10 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**18,22,23,26**;JUN 11, 2001;Build 43
+2 ;ACHS*3.1*18 7/16/2010;IHS/OIT/ABK;Change every occurrance of Deferred to Unmet Need
+3 ;
+4 ;this routine sets up certain basic vars for use in chs
+5 ;expected input: DUZ array
+6 ; U
+7 ; DT
+8 ;
+9 ;a partial list of the output:
+10 ;ACHSACFY the Active Current FY
+11 ;ACHSCFY the Current FY
+12 ;ACHSERR error flag default to off
+13 ;ACHSFC
+14 ;ACHSFYDT the start of the nbext FY, i.e, 3001001
+15 ;ACHSFYWK the workbook
+16 ;
+17 ;
+18 IF $DATA(^ACHSUSE("EOBR"))
Begin DoDot:1
+19 SET XQUIT=""
+20 WRITE @IOF,!!!,*7,*7
+21 WRITE $$C^XBFUNC("The global flag indicates EOBRs Are Now Being Processed"),!
+22 IF '$DATA(^XUSEC("ACHSZMGR",DUZ))
WRITE $$C^XBFUNC("Please Try Later"),!!!!!!
DO RTRN^ACHS
QUIT
+23 SET Y=$$DIR^XBDIR("Y","Do you want to delete the global flag and continue","N","","","^W !!,""You must enter 'Y' to delete the global flag, and provide access.""",1)
+24 IF $DATA(DIRUT)!('Y)
QUIT
+25 IF Y
Begin DoDot:2
+26 SET XQUIT=""
FOR
SET XQUIT=$ORDER(^ACHSUSE(XQUIT))
IF XQUIT=""
QUIT
KILL ^ACHSUSE(XQUIT)
+27 KILL XQUIT
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
IF $DATA(XQUIT)
QUIT
+30 ;
+31 ;ACHS*3.1*16 IHS.OIT.FCJ MODIFIED NXT LINE BECAUSE OF LENGTH
+32 ;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR AREA VAR
+33 ;{ABK,7/16/10}I '$D(^ACHSF(DUZ(2),2)) D NOTSET("Node 2 of the 'CHS FACILITY' file is missing for this facility '$D(^ACHSF("_DUZ(2)_",2)). Editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Deferred Services menu.")
+34 IF '$GET(ACHSISAO)
IF '$DATA(^ACHSF(DUZ(2),2))
DO NOTSET("Node 2 of the 'CHS FACILITY' file is missing for this facility '$D(^ACHSF("_DUZ(2)_",2)). Editing this file via Fileman or use the 'Parameters' option in the CHS Denial/Unmet Need menu.")
+35 ;
+36 ;5/29/01 pmf add check for ISAO
+37 IF $GET(ACHSISAO)
IF $PIECE($GET(^ACHSAOP(DUZ(2),2)),U)=""
DO NOTSET("The 'EOBR IMPORT/SPLITOUT EXPORT' field of the 'CHS AREA OFFICE PARAMETERS' file must contain a directory pathname $P(^ACHSAOP("_DUZ(2)_",2),U)=NULL")
+38 ;
+39 ;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR AREA VAR
+40 IF '$GET(ACHSISAO)
DO OPTS
+41 IF '$DATA(ACHSY)
GOTO END
+42 KILL ACHSY,ACHSCHSS
+43 DO ^ACHSUF
+44 IF $GET(ACHSERR)=1
SET XQUIT=1
GOTO END
+45 DO VIDEO^ACHS
+46 IF $PIECE($GET(^AUTTLOC(DUZ(2),0)),U,4)'=""
Begin DoDot:1
+47 IF $EXTRACT(($PIECE($GET(^AUTTAREA(($PIECE(^AUTTLOC(DUZ(2),0),U,4)),0)),U,4)))'="J"
DO CANZ
End DoDot:1
+48 QUIT
+49 ;
END ;
+1 WRITE *7
+2 IF $$DIR^XBDIR("E","Press RETURN...","","","","",2)
+3 SET ACHSXQT=1
+4 QUIT
+5 ;
OPTS ;
+1 ;
+2 SET ACHSY=""
+3 FOR ACHS=2:1
IF '$DATA(^DD(9002080,"GL",2,ACHS))
QUIT
SET ACHSY=$PIECE($GET(^ACHSF(DUZ(2),2)),U,ACHS)_ACHSY
+4 IF ACHSY]""
QUIT
+5 DO NOTSET("CHS Facility parameters not set")
+6 QUIT
+7 ;
NOTSET(ACHSMSG) ;
+1 DO VIDEO^ACHS
+2 WRITE !!,*7,"The "
WRITE $GET(IORVON)
WRITE "DENIAL"
WRITE $GET(IORVOFF)
WRITE " parameters for this site have "
+3 WRITE $GET(IORVON)
WRITE "not been properly set."
WRITE $GET(IORVOFF)
+4 WRITE !!,$$C^ACHS(ACHSMSG)
+5 WRITE !!,"Print this screen to a printer."
+6 WRITE *7,!!,$GET(IOBON),$GET(IORVON),"Contact your site manager immediately!",$GET(IOBOFF),$GET(IORVOFF)
+7 WRITE !!,"Press RETURN..."
+8 DO READ^ACHSFU
SET ACHS("NOTSET")=""
SET ACHSXQT=1
+9 QUIT
+10 ;
CANZ ;
+1 SET ACHSXARA=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,4)
+2 IF ACHSXARA'=""
SET ACHSXPFX=$PIECE($GET(^AUTTAREA(ACHSXARA,0)),U,4)
SET XCODE=$EXTRACT(ACHSXPFX,1)
+3 IF '$TEST
SET (ACHSXPFX,XCODE)=""
+4 IF XCODE="J"
GOTO CAN2
+5 WRITE *7,!!,"CAN NUMBER PREFIXES ARE BEING PROCESSED.........."
+6 DO WAIT^DICD
+7 FOR R=0:0
SET R=$ORDER(^ACHS(2,R))
WRITE "."
IF 'R
QUIT
IF $PIECE($GET(^ACHS(2,R,0)),U,3)=DUZ(2)
Begin DoDot:1
+8 SET ACHSXX=$PIECE($GET(^ACHS(2,R,0)),U)
SET ACHSX3=$EXTRACT(ACHSXX,1,3)
SET ACHSX4=$EXTRACT(ACHSXX,4,7)
KILL ^ACHS(2,"B",ACHSXX,R)
SET ACHSX3="J"_$EXTRACT(ACHSX3,2,3)
+9 SET $PIECE(^ACHS(2,R,0),U)=ACHSX3_ACHSX4
SET ^ACHS(2,"B",ACHSX3_ACHSX4,R)=""
+10 QUIT
End DoDot:1
+11 SET $PIECE(^AUTTAREA(ACHSXARA,0),U,4)="J"_$EXTRACT(ACHSXPFX,2,3)
CAN2 ;
+1 KILL R,X,ACHSXARA,ACHSXPFX,XCODE,ACHSXX,ACHSX3,ACHSX4
+2 QUIT
+3 ;
MGR ;EP - If options not set, user has mgr key, enter the options.
+1 IF '$DATA(^XUSEC("ACHSZMGR",DUZ))
QUIT
+2 SET ACHSSITE=$PIECE($GET(^DIC(4,DUZ(2),0)),U)
+3 DO OPTIONS
+4 KILL ACHSSITE
+5 IF $DATA(^ACHSF(DUZ(2),2))
IF $LENGTH(^(2))
SET ACHSY=""
+6 QUIT
+7 ;
OPTIONS ;
+1 NEW DA,DIC,DIE,DR,DLAYGO
+2 WRITE !!!,"Edit the CHS facility options for '",ACHSSITE,"'.",!!,"1 question mark (""?"") will get you help.",!!,"2 question marks (""??"") usually gets you more help.",!!
+3 WRITE "For printed help, print out chapter 1 of the Tech Manual (D ^ACHSTM).",!
+4 ;ACHS*3.1*16 11.12.2009 IHS.OIT.FCJ ADDED DUNS TO NXT LINE;ACHS*3.1*23 REM EOBR PRINT;3.1*26-ADD FILE DIRECTORY
+5 SET DIE="^ACHSF("
SET DR="11.03;11.05:14.08;14.11:14.13;14.15:14.18;14.2;14.22;14.24:14.27;14.31;.05"
SET DA=DUZ(2)
+6 DO ^DIE
+7 ; Quit if not a 638 facility.
IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,8)'="Y"
QUIT
+8 SET DR="11.04;14.09"
+9 DO ^DIE
+10 IF $PIECE($GET(^ACHSF(DUZ(2),0)),U,6)
IF $PIECE($GET(^(0)),U,7)
QUIT
+11 WRITE *7,!!,"THE NEXT 2 PARAMETERS DETERMINE WHEN YOUR FISCAL YEAR STARTS.",!!,"IF YOU HAVE ANY DOUBTS ABOUT HOW TO ANSWER THE QUESTIONS, PLEASE CALL",!!,"DSD AT 999-999-9999 AND ASK FOR THE CHS DEVELOPER.",!
+12 SET DR="11.01;11.02"
+13 DO ^DIE
+14 QUIT
+15 ;
FY(%) ;EP - Given a FY, return beg/end dates.
+1 NEW X,Y
+2 SET X=$PIECE($GET(^ACHSF(DUZ(2),0)),U,6)
SET Y=+$PIECE($GET(^(0)),U,7)
+3 SET %=$SELECT(%>50:2,1:3)_%-Y
+4 SET X=%_X
+5 SET %=$EXTRACT(X,1,3)
+6 ; Year
SET Y=%+$SELECT($EXTRACT(X,4,7)="0101":0,1:1)
+7 SET %=$EXTRACT(X,4,5)
IF $EXTRACT(X,6,7)="01"
SET %=%-1
IF '%
SET %=12
+8 ; Month
SET %="0"_%
SET %=$EXTRACT(%,$LENGTH(%)-1,$LENGTH(%))
+9 ; Day
SET Y=$EXTRACT(Y,1,3)_%_$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,%)
+10 IF $EXTRACT(Y,4,5)="02"
IF '((1700+$EXTRACT(Y,1,3))#4)
SET Y=$EXTRACT(Y,1,5)_"29"
+11 IF $EXTRACT(X,4,5)=$EXTRACT(Y,4,5)
SET %=$EXTRACT(X,6,7)
SET %=%-1
SET %="0"_%
SET %=$EXTRACT(%,$LENGTH(%)-1,$LENGTH(%))
SET Y=$EXTRACT(Y,1,5)_%
+12 QUIT X_U_Y
+13 ;
