ACHS ;IHS/ITSC/PMF - CHS SUB-ROUTINES ; [ 01/18/2005 1:14 PM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**2,4,5,7,12,17,18,22**;JUNE 11,2001;Build 43
;
AD(P) ;EP -P=piece of AO DIR
Q $P($G(^ACHSDENR(DUZ(2),200)),U,P)
C(X,Y) ;EP -Center X in field len Y
Q $J("",$S($D(Y):Y,$D(IOM):IOM,1:80)-$L(X)\2)_X
AOP(N,P) ;EP -N=node, P=piece, ret AO Par
Q $P($G(^ACHSAOP(DUZ(2),N)),U,P)
SUD(P) ;EP -P=piece of SU DIR info
Q $P($G(^ACHSDENR(DUZ(2),100)),U,P)
ASF(F) ;EP -Ret ASUFAC given DUZ(2) ;allows alpha in aufac
Q:'$D(F) -1
Q:'F -1
S F=$P($G(^AUTTLOC(F,0)),U,10)
Q:'($L(F)=6) -1
I F'?6NA Q -1
Q F
BM ;EP -Set bot mar to ACHSBM
S ACHSBM=IOSL-10
I '$D(IO("S")),'$D(ZTQUEUED),IO=IO(0) S ACHSBM=IOSL-4
Q
BRPT ;EP -Stand beg of rpt
I $D(ACHSQIO) F S IOP=ACHSQIO D ^%ZIS Q:'POP H 30
D BM,NOW
S ACHSTIME=$$C^XBFUNC($G(ACHSTIME),80)
S ACHSLOC=$$C^XBFUNC($$LOC,80)
S ACHSPG=0
S ACHSUSR=$$USR
U IO
Q
CLEAN(FROM) ;EP fr ACHSAVAR-clean err glb>90 days
S:FROM="" FROM=$H-90_",00000"
F S FROM=$O(^ACHSERR(FROM),-1) Q:FROM="" D
.K ^ACHSERR(FROM)
Q
;IF USER-Manager-WARN THEM OF ERR MESS IN ^ACHSERR-CALLED AT THE ENTRY ACT FOR OPT
ISMGR(TMPDUZ) ;EP-opt ACHSMENU
Q:'$D(^ACHSERR)
D VIDEO
S $P(LINE,"-",IOM+1)=""
S KEYNUM=$O(^DIC(19.1,"B","ACHSZMENU","")) ;GET KEY
Q:'$D(^VA(200,TMPDUZ,51,"B",KEYNUM))
W !!,$G(IOBON),$G(IORVON),"You have error messages concerning missing"
W !,"facility or area parameters!!",$G(IOBOFF),$G(IORVOFF)
W !!,"Please take a look at global ^ACHSERR"
W !!!,"Press return to continue..."
D READ^ACHSFU
D ISMGRHD ;HDR FOR ERR MESS FILE
S %H=""
F S %H=$O(^ACHSERR(%H)) Q:%H="" D
.D YX^%DTC S NOW=Y
.I $Y>(IOSL-2),(IO(0)=IO) W !!,"Press return to continue..." D READ^ACHSFU D ISMGRHD
.W !!,NOW,?25,$G(^ACHSERR(%H))
W !!!,"Press return to continue..."
D READ^ACHSFU
K LINE,%H,NOW,KEYNUM
Q
;HDR FOR ABOVE SUB
ISMGRHD ;EP
W @IOF
W !,"DATE",?15,"TIME",?25,"MESSAGE"
W !,LINE
Q
CLOSEALL ;EP -Close all HFS dev
S ACHS=""
F S ACHS=$O(IO(1,ACHS)) Q:'ACHS S IO=ACHS D ^%ZISC
Q
DIR(O,A,B,Q,H,R) ;EP -^DIR interface
I '$L($G(O)) Q -1
N DIR
S DIR(0)=O
I $L($G(A)) S DIR("A")=A I $L($O(A(""))) S O="" F S O=$O(A(O)) Q:'$L(O) S DIR("A",O)=A(O)
I $L($G(B)) S DIR("B")=B
I $L($G(Q)) S DIR("?")=Q
I $L($G(H)) S DIR("??")=H
I $G(R) F A=1:1:R W !
K O,A,B,Q,H,R,DTOUT,DUOUT,DIRUT,DIROUT
D ^DIR
Q Y
CPI ;EP
W !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"
Q
DATE(A,N,M) ;EP - prmpt for dt
; A = "B" or "E"; N = Report Name;M = Modifier for prompt
K DTOUT,DUOUT,DIRUT,DIROUT
I '$L($G(A)) Q -1
I '("BE"[$E(A)) Q -1
I '$D(N) Q -1
S A="Enter The "_$S(A="B":"BEGINNING",1:"ENDING")_$S($L($G(M)):" "_M,1:"")_" Date For The "_N_" Report"
K N,M
F W !! S Y=$$DIR^XBDIR("DO^::E",A) Q:'(Y>DT) D FUDT
Q Y
DIC(D,O,A,B,S) ;EP -DIC Lookup
N DIC
S DIC=D,DIC(0)=$G(O)
I $L($G(A)) S DIC("A")=A
I $L($G(B)) S DIC("B")=B
D ^DIC
Q Y
DIE(DR,Z) ;EP -Ed Doc fld
I $G(Z) F %=1:1:Z W !
S DA=ACHSDIEN,DA(1)=DUZ(2),DIE="^ACHSF("_DUZ(2)_",""D"","
I '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+") S DUOUT="" Q 0
D ^DIE
I '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-") S DUOUT="" Q 0
I $D(Y) Q 0
Q 1
DIET(DR,Z) ;EP - Ed Trans fields
I $G(Z) F %=1:1:Z W !
S DA=ACHSTIEN,DA(1)=ACHSDIEN,DA(2)=DUZ(2),DIE="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",""T"","
I '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN,""T"",ACHSTIEN)","+") S DUOUT="" Q 0
D ^DIE
I '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN,""T"",ACHSTIEN)","-") S DUOUT="" Q 0
I $D(Y) Q 0
Q 1
DF(S,P) ;EP - Ret Def Svc fr node S, piece P
NEW Y
S Y=$G(ACHSA)
I Y="" S Y=$G(ACHSDA)
I Y="" Q 0
Q $P($G(^ACHSDEF(DUZ(2),"D",Y,S)),U,P)
DN(S,P) ;EP - Ret Denial data from node S, piece P
Q $P($G(^ACHSDEN(DUZ(2),"D",ACHSA,S)),U,P)
DOC(S,P) ;EP - Ret Doc data from node S, piece P
Q $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,S)),U,P)
EBB(B,E) ;EP - Compare Beg and End dates for a rep
I '(E<B) Q 0
W !!,*7,"The END date is before the BEGINNING date."
Q 1
ERPT ;EP - Stand end of a rep
D ^%ZISC
K ACHS,ACHSBDT,ACHSBM,ACHSEDT,ACHSIO,ACHSLOC,ACHSPG,ACHSQIO,ACHSRPT,ACHST1,ACHST2,ACHST3,ACHSTIME,ACHSUSR,ACHSX,ACHSY,DTOUT,DUOUT,X2,X3,Y
K ACHD,ACHDBDT,ACHDBM,ACHDEDT,ACHDHAT,ACHDIO,ACHDLOC,ACHDPG,ACHDQIO,ACHDRPT,ACHDT1,ACHDT2,ACHDT3,ACHDTIME,ACHDUSR,ACHDX,ACHDY
Q
EX() ;EP - Ret file Exp dir
I $$OS=1,$L($P($G(^AUTTSITE(1,1)),U,2)) Q $P($G(^AUTTSITE(1,1)),U,2) ;unx
I $$OS=2,$L($P($G(^AUTTSITE(1,1)),U,2)) Q $P($G(^AUTTSITE(1,1)),U,2)
Q "C:\EXPORT\"
FC(Y) ;EP -Ret Fin Code-site Y=DUZ(2)
N X
I Y="" Q "UNDEFINED"
S X=$P($G(^AUTTLOC(Y,0)),U,4)
I X="" Q "UNDEFINED"
Q $P($G(^AUTTAREA(X,0),"UNDEFINED"),U,3)_$E($P($G(^AUTTLOC(Y,0),"UNDEFINED"),U,17),2,3)
FMT ;EP
S:'$D(X2) X2="2$"
S:'$D(X3) X3=0
D COMMA^%DTC
S:'X3 X=$P(X," ")
W X
K X2,X3
Q
FUDT ;EP
W !!,*7,"Do not use future dates."
Q
FYSEL(X) ;EP
D:'$G(X) SB1^ACHSFU
N MIN,MAX
; FY selection if in the CHS globals
F %=0:0 S %=$O(ACHSFYWK(DUZ(2),%)) Q:'% S MIN=$S('$D(MIN):%,1:MIN),MAX=%
S O="N^"_MIN_":"_MAX_":0",B=MAX
K MIN,MAX
Q $$DIR^XBDIR(O,"ENTER FISCAL YEAR",B,"","Invalid FY, Enter FY with all 4 digits","^D SB1^ACHSFU",1)
GDT(JDT) ;EP -JDT-Julian Date, ret Gregorian Date-Ext format
Q:'$G(JDT) -1
Q:JDT<0 -1
Q:JDT>366 -1
Q $$HTE^XLFDT($P($$FMTH^XLFDT($S(JDT>$$JDT(DT):($E(DT,1,3)-1),1:$E(DT,1,3))_"0101"),",")+JDT-1)
;
Q "NOT FOUND"
H ;EP -menu header
;D VIDEO
W @IOF
D STATUSLN
D VIDEO
;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ NXT 4 LINES
S X=$O(^DIC(9.4,"C","ACHS",0)) ;ACHS*3.1*18
S V=$G(^DIC(9.4,X,"VERSION")) ;ACHS*3.1*18
S A=$O(^DIC(9.4,X,22,"B",V,0)) ;ACHS*3.1*18
S P=0 F S P=$O(^DIC(9.4,X,22,A,"PAH","B",P)) Q:P'?1.N.N S P1=P ;ACHS*3.1*18
S MENTITLE=$J("",2*$L(IORVON)-1)_IORVON_$P(XQY0,U,2)_IORVOFF
;W !!!,$$C^XBFUNC($P($T(ACHS+1),";",4)_", "_$$CV^XBFUNC("ACHS")),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(MENTITLE) ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ
W !!,$$C^XBFUNC($P($T(ACHS+1),";",4)),!,$$C^XBFUNC("VERSION: "_$$CV^XBFUNC("ACHS")_" PATCH "_P1),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(MENTITLE) ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ
Q
STATUSLN ;
I $$VERSION^%ZOSV(1)["NT" Q
S JOB=$J
X ^%ZOSF("UCI") ;GET CURRENT UCI,VOL
S MYLINE="Device: "_$G(IO)_" Job no.: "_JOB_" "_$S($$OS^ACHS=2:"Windows",1:"Unix")_" Device: "_$G(IO("ZIO"))_" [UCI,VOL]: "_Y
D PREP^XGF
D SAY^XGF(1,1,MYLINE,"R1")
D CLEAN^XGF
Q
;
HELP(L,R) ;EP -Dis at label L, RTN R
N X
W !
F %=1:1 S X=$T(@L+%^@R) Q:($P(X,";",3)="###")!(X="") D
. I $P(X,";",3)="@" W @($P(X,";",4)) Q
. W !?4,$P(X,";",3)
.Q
Q
;
HRN(P,L) ;EP -Ret HRN for DFN-P DUZ(2)-L
;ITSC/SET/JVK ACHS*3.1*12 ADD BELOW COMMENT FOR IHS/OKCAO/POC PAWNEE BEN. PKG.
;I +$P($G(^AUTTLOC(DUZ(2),0)),U,1)=505613 Q $$GET1^DIQ(1808000,P_",",1
Q $P($G(^AUPNPAT(P,41,L,0)),U,2)
;
IM() ;EP - ReT file Imp dir
I $$OS=1,$L($P($G(^AUTTSITE(1,1)),U)) Q $P($G(^AUTTSITE(1,1)),U) ;UNIX IMPORT PATH
I $$OS=2,$L($P($G(^AUTTSITE(1,1)),U)) Q $P($G(^AUTTSITE(1,1)),U) ;DOS IMPORT PATH
Q "C:\IMPORT\"
;
INSURED(DFN,ACHSDATE) ;EP - Does pt have INS on a dt
I $$MCR^AUPNPAT2(DFN,ACHSDATE) Q 1
I $$MCD^AUPNPAT2(DFN,ACHSDATE) Q 1
I $$PI^AUPNPAT2(DFN,ACHSDATE) Q 1
I $$RRE(DFN,ACHSDATE) Q 1
Q 0
;
JDT(X1,ACHS) ;EP - Given FM dt, Ret Julian Dt. IF ACHS, 3 places.
Q:'$D(X1) -1
Q:'(X1?7N) -1
S X2=$E(X1,1,3)_"0101"
D ^%DTC
I '$G(ACHS) Q X+1
S ACHS=X+1,ACHS="000"_ACHS
Q $E(ACHS,$L(ACHS)-2,$L(ACHS))
;
JTF(JDT) ;EP - Given Julian dt ret fm dt
Q:'$G(JDT) -1
Q:JDT<0 -1
Q:JDT>366 -1
Q $$FMADD^XLFDT($S(JDT>$$JDT(DT):($E(DT,1,3)-1),1:$E(DT,1,3))_"0101",JDT-1)
;
L(F,N) ;EP - F = File #; N = Field #.
Q:$D(ZTQUEUED)!$D(IO("S"))!($G(IOST)'["C-")
W !?($L($P($G(^DD(F,N,0)),U))+1),"|",$$REPEAT^XLFSTR("-",+$P($P($G(^DD(F,N,0)),U,5),">",2)),"|"
Q
;
LOC() ;EP - Ret loc
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P($G(^DIC(4,DUZ(2),0)),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;
LOCK(V,M) ;EP - LOCK var V, mode M (+/-).
I '$L($G(M)) W !,"MODE NOT DEFINED IN LOCK CALL." D RTRN Q 0
I '("+-"[$G(M)) W !,"BAD MODE PARAMETER IN LOCK CALL." D RTRN Q 0
N C,L
S C=0,L=10
G:M="-" LOCK1
F LOCK +@V:3 G:$T LOCK2 G:C=L LOCK2 D LOCKMSG
Q:$T ;FCJ
LOCK1 ;
F LOCK -@V:3 Q:$T Q:C=L D LOCKMSG
LOCK2 ;
E W:'$D(ZTQUEUED) *7,*7,!,$S(M="-":"UN",1:""),"LOCK OF '",V,"' FAILED.",!!,"NOTIFY PROGRAMMER IMMEDIATELY." D RTRN I 0
Q $T
;
LOCKMSG ;
S C=C+1
Q:$D(ZTQUEUED)
W !,$S(M="-":"UN",1:""),"LOCK of node '",V,"' failed. Retry ",C," of ",L,"."
Q
;
LOGO ;EP - Dis logo-main menu
N A,D,I,L,N,R,V
S L=18,R=61,D=R-L+1,N=R-L-1
;
S I=$O(^DIC(9.4,"C","ACHS",0)) ;CHECK FOR IEN OF ACHS PACKAGE ENTRY
I I="" W !!,"PACKAGE FILE ENTRY FOR THE 'CONTRACT HEALTH MGMT SYSTEM' IS INCOMPLETE!",!,"INFORM YOUR SITE MANAGER IMMEDIATELY!!" Q
;
S V=$G(^DIC(9.4,I,"VERSION")) ;CHECK CURRENT VERSION NUMBER
I V="" W !!,"PACKAGE FILE ENTRY FOR THE 'CONTRACT HEALTH MGMT SYSTEM' IS INCOMPLETE!",!,"INFORM YOUR SITE MANAGER IMMEDIATELY!!"
;
S A=$O(^DIC(9.4,I,22,"B",V,0)) ;
S Y=$$FMTE^XLFDT($P($G(^DIC(9.4,I,22,A,0)),U,2)) ;'DATE DISTIBUTED'
S P=0 F S P=$O(^DIC(9.4,I,22,A,"PAH","B",P)) Q:P'?1.N.N S P1=P ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ ADDED LINE, SPLIT NXT LINE AND ADDED PATCH #
W @IOF,!,$$C^XBFUNC($$REPEAT^XLFSTR("*",D)),!?L,"*",$$C^XBFUNC("Indian Health Service",N),?R,"*",!?L,"*",$$C^XBFUNC($P($T(ACHS+1),";",4),N),?R,"*"
W !?L,"*",$$C^XBFUNC("Version "_V_" Patch "_P1_", "_Y,N),?R,"*",!,$$C^XBFUNC($$REPEAT^XLFSTR("*",D))
W !!,$$C^XBFUNC($$LOC())
Q
NOW ;EP - Set cur time into ACHSTIME
S ACHSTIME=$$HTE^XLFDT($H)
Q
OS() ;EP - Ret OS fr ^%ZOSF("OS") or RPMS Site file.
I $G(^%ZOSF("OS"))["MSM-UNIX" Q 1
I $G(^%ZOSF("OS"))["MSM-PC" Q 2
I $G(^%ZOSF("OS"))["OpenM-NT",($P($G(^AUTTSITE(1,0)),U,21)) Q $P($G(^AUTTSITE(1,0)),U,21)
I $P($G(^AUTTSITE(1,0)),U,21) Q $P($G(^AUTTSITE(1,0)),U,21)
Q 1 ; Default is UNIX if "OS" and RPMS SITE can't determine.
PARM(N,P) ;EP - N = node, P= piece, return the fac parameter value.
Q $P($G(^ACHSF(DUZ(2),N)),U,P)
PB() ;EP - Print/Browse.
Q $$DIR^XBDIR("SO^P:PRINT Output;B:BROWSE Output on Screen","Do you want to ","PRINT","","","",2)
PTLK ;EP Stand pt lookup using DIC.
N ACHSDUZ2
I $$PARM(2,5)="Y" S ACHSDUZ2=DUZ(2),DUZ(2)=0
;IHS/OKCAO/POC PAWNEE BEN
I +$P($G(^AUTTLOC(DUZ(2),0)),U,10)=505613 D
.D PAWNEE
.Q
E D
.S DIC="^AUPNPAT(",DIC(0)="AEMQ",AUPNLK("INAC")=""
.I $G(DFN),$D(^DPT(DFN,0)) S DIC("B")=$P($G(^DPT(DFN,0)),U)
.D ^DIC
.K DFN,DIC,AUPNLK("INAC")
.I Y'<1 S DFN=+Y
;ITSC/SET/JVK END CHGS
I $G(ACHSDUZ2) S ACHSYAYA=ACHSDUZ2,DUZ(2)=ACHSDUZ2
K ACHSYAYA
Q
RPL(X,Y,Z) ;EP - In X, Replace Y with Z.
F Q:'$F(X,Y) S X=$P(X,Y,1)_Z_$P(X,Y,2,999)
Q X
RTRN ;EP - ask usr to press RET
S ACHSQUIT=0
I IOST["C-",'$D(IO("S")) S Y=$$DIR^XBDIR("E","Press RETURN To Continue or ^ to Exit or Cancel...","","","",1) X ^%ZOSF("TRMRD") I Y=0!(Y=27)!(X=U) S ACHSQUIT=1
Q
SB(X) ;EP - Strip leading & trailing blanks from X.
X ^DD("FUNC",$O(^DD("FUNC","B","STRIPBLANKS",0)),1)
Q X
TRAN(S,P) ;EP - Ret Transaction data from node S, piece P
; S will always be 0.
Q $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,S)),U,P)
USR() ;EP - Ret name of current user for ^VA(200.
I $G(DUZ)="" Q "DUZ UNDEFINED"
I $G(DUZ)=0 Q "DUZ IS 0"
I $D(^VA(200,DUZ,0))#2 Q $P(^VA(200,DUZ,0),U,1)
Q "UNK"
VIDEO ;EP - Set reverse video vars
S X="IORVON;IORVOFF;IOBON;IOBOFF;IOINORM" D ENDR^%ZISS
;At list vars code for normal follows codes for blinking and reverse.
S IZZZNORM=$G(IOINORM)
Q
YN ;EP
W !!,"Enter a ""Y"" for YES or an ""N"" for NO."
Q
HDR ;EP - Print menu header.
S X=$O(^DIC(19,"B",X,0))
I X="" W !!,"MENU HEADER CANNOT BE PRINTED!" Q
S X=$P($G(^DIC(19,X,0)),U,2)
G SHDR
PHDR ;EP - Print parent menu header.
S X=$P($G(^DIC(19,+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1),0)),U,2)
Q:'$L(X)
S Y=+^XUTL("XQ",$J,^XUTL("XQ",$J,"T")-1)
I Y=0 W !!,"PARENT MENU CANNOT BE FOUND IN XUTL!" Q
S Y=$P($G(^DIC(19,Y,0)),U)
I Y="ACHSMENU" D LOGO Q
SHDR ;EP - Screen header.
I '$D(IORVOFF) D VIDEO
W @IOF,!,$$C^XBFUNC($P($T(ACHS+1),";",4)),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(X),!!
Q
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;EP - Return 0th node. A is file #, rest fields.
N Z
I '$G(A) Q -1
I '$G(B) Q -1
F Z=67:1:75 Q:'$G(@($C(Z))) S A=+$P($G(^DD(A,B,0)),U,2),B=@($C(Z))
I 'A!('B) Q -1
I '$D(^DD(A,B,0)) Q -1
Q U_$P($G(^DD(A,B,0)),U,2)
RRE(P,D) ; Does pt have Railroad insurance on date? 1 = yes, 0 = no.
; I = IEN in ^AUPNRRE multiple.
I '$G(P) Q 0
I '$G(D) Q 0
N I,Y
S Y=0,U="^"
I '$D(^DPT(P,0)) G RREX
I $P($G(^DPT(P,0)),U,19) G RREX
I '$D(^AUPNPAT(P,0)) G RREX
I '$D(^AUPNRRE(P,11)) G RREX
I $D(^DPT(P,.35)),$P(^DPT(P,.35),U)]"",$P($G(^DPT(P,.35)),U)<D G RREX
S I=0
F S I=$O(^AUPNRRE(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNRRE(P,11,I,0),U)>D
. I $P($G(^AUPNRRE(P,11,I,0)),U,2)]"",$P($G(^AUPNRRE(P,11,I,0)),U,2)<D Q
. S Y=1
.Q
RREX ;
Q Y
FY(%) ;EP - Given a FY, return beg/end dates.
NEW X,Y
S X=$P($G(^ACHSF(DUZ(2),0)),U,6),Y=+$P($G(^ACHSF(DUZ(2),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
PAWNEE ;IHS/OKCAO/POC PAWNEE BEN PKG
S DIC=1808000,DIC(0)="IQAZEM" S:+$G(DFN) DIC("B")=$P($G(^DPT(DFN,0)),U)
D ^DIC K DIC
I $D(DUOUT)!(+Y<0) K DFN Q
S DFN=+Y,ACHSBPNO=$P($G(^AZOPBPP(+Y,0)),U,2)
W !,"PAWNEE BENEFIT NUMBER: ",ACHSBPNO
S PBEXDT=+$P($G(^AZOPBPP(+Y,0)),U,3),Y=PBEXDT X ^DD("DD")
I PBEXDT<DT W !!,*7,"PBPP Eligibility Card Expired on ",Y," --TRANSACTION CANCELLED" K DFN Q
Q
ACHS ;IHS/ITSC/PMF - CHS SUB-ROUTINES ; [ 01/18/2005 1:14 PM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**2,4,5,7,12,17,18,22**;JUNE 11,2001;Build 43
+2 ;
AD(P) ;EP -P=piece of AO DIR
+1 QUIT $PIECE($GET(^ACHSDENR(DUZ(2),200)),U,P)
C(X,Y) ;EP -Center X in field len Y
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,$DATA(IOM):IOM,1:80)-$LENGTH(X)\2)_X
AOP(N,P) ;EP -N=node, P=piece, ret AO Par
+1 QUIT $PIECE($GET(^ACHSAOP(DUZ(2),N)),U,P)
SUD(P) ;EP -P=piece of SU DIR info
+1 QUIT $PIECE($GET(^ACHSDENR(DUZ(2),100)),U,P)
ASF(F) ;EP -Ret ASUFAC given DUZ(2) ;allows alpha in aufac
+1 IF '$DATA(F)
QUIT -1
+2 IF 'F
QUIT -1
+3 SET F=$PIECE($GET(^AUTTLOC(F,0)),U,10)
+4 IF '($LENGTH(F)=6)
QUIT -1
+5 IF F'?6NA
QUIT -1
+6 QUIT F
BM ;EP -Set bot mar to ACHSBM
+1 SET ACHSBM=IOSL-10
+2 IF '$DATA(IO("S"))
IF '$DATA(ZTQUEUED)
IF IO=IO(0)
SET ACHSBM=IOSL-4
+3 QUIT
BRPT ;EP -Stand beg of rpt
+1 IF $DATA(ACHSQIO)
FOR
SET IOP=ACHSQIO
DO ^%ZIS
IF 'POP
QUIT
HANG 30
+2 DO BM
DO NOW
+3 SET ACHSTIME=$$C^XBFUNC($GET(ACHSTIME),80)
+4 SET ACHSLOC=$$C^XBFUNC($$LOC,80)
+5 SET ACHSPG=0
+6 SET ACHSUSR=$$USR
+7 USE IO
+8 QUIT
CLEAN(FROM) ;EP fr ACHSAVAR-clean err glb>90 days
+1 IF FROM=""
SET FROM=$HOROLOG-90_",00000"
+2 FOR
SET FROM=$ORDER(^ACHSERR(FROM),-1)
IF FROM=""
QUIT
Begin DoDot:1
+3 KILL ^ACHSERR(FROM)
End DoDot:1
+4 QUIT
+5 ;IF USER-Manager-WARN THEM OF ERR MESS IN ^ACHSERR-CALLED AT THE ENTRY ACT FOR OPT
ISMGR(TMPDUZ) ;EP-opt ACHSMENU
+1 IF '$DATA(^ACHSERR)
QUIT
+2 DO VIDEO
+3 SET $PIECE(LINE,"-",IOM+1)=""
+4 ;GET KEY
SET KEYNUM=$ORDER(^DIC(19.1,"B","ACHSZMENU",""))
+5 IF '$DATA(^VA(200,TMPDUZ,51,"B",KEYNUM))
QUIT
+6 WRITE !!,$GET(IOBON),$GET(IORVON),"You have error messages concerning missing"
+7 WRITE !,"facility or area parameters!!",$GET(IOBOFF),$GET(IORVOFF)
+8 WRITE !!,"Please take a look at global ^ACHSERR"
+9 WRITE !!!,"Press return to continue..."
+10 DO READ^ACHSFU
+11 ;HDR FOR ERR MESS FILE
DO ISMGRHD
+12 SET %H=""
+13 FOR
SET %H=$ORDER(^ACHSERR(%H))
IF %H=""
QUIT
Begin DoDot:1
+14 DO YX^%DTC
SET NOW=Y
+15 IF $Y>(IOSL-2)
IF (IO(0)=IO)
WRITE !!,"Press return to continue..."
DO READ^ACHSFU
DO ISMGRHD
+16 WRITE !!,NOW,?25,$GET(^ACHSERR(%H))
End DoDot:1
+17 WRITE !!!,"Press return to continue..."
+18 DO READ^ACHSFU
+19 KILL LINE,%H,NOW,KEYNUM
+20 QUIT
+21 ;HDR FOR ABOVE SUB
ISMGRHD ;EP
+1 WRITE @IOF
+2 WRITE !,"DATE",?15,"TIME",?25,"MESSAGE"
+3 WRITE !,LINE
+4 QUIT
CLOSEALL ;EP -Close all HFS dev
+1 SET ACHS=""
+2 FOR
SET ACHS=$ORDER(IO(1,ACHS))
IF 'ACHS
QUIT
SET IO=ACHS
DO ^%ZISC
+3 QUIT
DIR(O,A,B,Q,H,R) ;EP -^DIR interface
+1 IF '$LENGTH($GET(O))
QUIT -1
+2 NEW DIR
+3 SET DIR(0)=O
+4 IF $LENGTH($GET(A))
SET DIR("A")=A
IF $LENGTH($ORDER(A("")))
SET O=""
FOR
SET O=$ORDER(A(O))
IF '$LENGTH(O)
QUIT
SET DIR("A",O)=A(O)
+5 IF $LENGTH($GET(B))
SET DIR("B")=B
+6 IF $LENGTH($GET(Q))
SET DIR("?")=Q
+7 IF $LENGTH($GET(H))
SET DIR("??")=H
+8 IF $GET(R)
FOR A=1:1:R
WRITE !
+9 KILL O,A,B,Q,H,R,DTOUT,DUOUT,DIRUT,DIROUT
+10 DO ^DIR
+11 QUIT Y
CPI ;EP
+1 WRITE !?21,"*** CONFIDENTIAL PATIENT INFORMATION ***"
+2 QUIT
DATE(A,N,M) ;EP - prmpt for dt
+1 ; A = "B" or "E"; N = Report Name;M = Modifier for prompt
+2 KILL DTOUT,DUOUT,DIRUT,DIROUT
+3 IF '$LENGTH($GET(A))
QUIT -1
+4 IF '("BE"[$EXTRACT(A))
QUIT -1
+5 IF '$DATA(N)
QUIT -1
+6 SET A="Enter The "_$SELECT(A="B":"BEGINNING",1:"ENDING")_$SELECT($LENGTH($GET(M)):" "_M,1:"")_" Date For The "_N_" Report"
+7 KILL N,M
+8 FOR
WRITE !!
SET Y=$$DIR^XBDIR("DO^::E",A)
IF '(Y>DT)
QUIT
DO FUDT
+9 QUIT Y
DIC(D,O,A,B,S) ;EP -DIC Lookup
+1 NEW DIC
+2 SET DIC=D
SET DIC(0)=$GET(O)
+3 IF $LENGTH($GET(A))
SET DIC("A")=A
+4 IF $LENGTH($GET(B))
SET DIC("B")=B
+5 DO ^DIC
+6 QUIT Y
DIE(DR,Z) ;EP -Ed Doc fld
+1 IF $GET(Z)
FOR %=1:1:Z
WRITE !
+2 SET DA=ACHSDIEN
SET DA(1)=DUZ(2)
SET DIE="^ACHSF("_DUZ(2)_",""D"","
+3 IF '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN)","+")
SET DUOUT=""
QUIT 0
+4 DO ^DIE
+5 IF '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN)","-")
SET DUOUT=""
QUIT 0
+6 IF $DATA(Y)
QUIT 0
+7 QUIT 1
DIET(DR,Z) ;EP - Ed Trans fields
+1 IF $GET(Z)
FOR %=1:1:Z
WRITE !
+2 SET DA=ACHSTIEN
SET DA(1)=ACHSDIEN
SET DA(2)=DUZ(2)
SET DIE="^ACHSF("_DUZ(2)_",""D"","_ACHSDIEN_",""T"","
+3 IF '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN,""T"",ACHSTIEN)","+")
SET DUOUT=""
QUIT 0
+4 DO ^DIE
+5 IF '$$LOCK("^ACHSF(DUZ(2),""D"",ACHSDIEN,""T"",ACHSTIEN)","-")
SET DUOUT=""
QUIT 0
+6 IF $DATA(Y)
QUIT 0
+7 QUIT 1
DF(S,P) ;EP - Ret Def Svc fr node S, piece P
+1 NEW Y
+2 SET Y=$GET(ACHSA)
+3 IF Y=""
SET Y=$GET(ACHSDA)
+4 IF Y=""
QUIT 0
+5 QUIT $PIECE($GET(^ACHSDEF(DUZ(2),"D",Y,S)),U,P)
DN(S,P) ;EP - Ret Denial data from node S, piece P
+1 QUIT $PIECE($GET(^ACHSDEN(DUZ(2),"D",ACHSA,S)),U,P)
DOC(S,P) ;EP - Ret Doc data from node S, piece P
+1 QUIT $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,S)),U,P)
EBB(B,E) ;EP - Compare Beg and End dates for a rep
+1 IF '(E<B)
QUIT 0
+2 WRITE !!,*7,"The END date is before the BEGINNING date."
+3 QUIT 1
ERPT ;EP - Stand end of a rep
+1 DO ^%ZISC
+2 KILL ACHS,ACHSBDT,ACHSBM,ACHSEDT,ACHSIO,ACHSLOC,ACHSPG,ACHSQIO,ACHSRPT,ACHST1,ACHST2,ACHST3,ACHSTIME,ACHSUSR,ACHSX,ACHSY,DTOUT,DUOUT,X2,X3,Y
+3 KILL ACHD,ACHDBDT,ACHDBM,ACHDEDT,ACHDHAT,ACHDIO,ACHDLOC,ACHDPG,ACHDQIO,ACHDRPT,ACHDT1,ACHDT2,ACHDT3,ACHDTIME,ACHDUSR,ACHDX,ACHDY
+4 QUIT
EX() ;EP - Ret file Exp dir
+1 ;unx
IF $$OS=1
IF $LENGTH($PIECE($GET(^AUTTSITE(1,1)),U,2))
QUIT $PIECE($GET(^AUTTSITE(1,1)),U,2)
+2 IF $$OS=2
IF $LENGTH($PIECE($GET(^AUTTSITE(1,1)),U,2))
QUIT $PIECE($GET(^AUTTSITE(1,1)),U,2)
+3 QUIT "C:\EXPORT\"
FC(Y) ;EP -Ret Fin Code-site Y=DUZ(2)
+1 NEW X
+2 IF Y=""
QUIT "UNDEFINED"
+3 SET X=$PIECE($GET(^AUTTLOC(Y,0)),U,4)
+4 IF X=""
QUIT "UNDEFINED"
+5 QUIT $PIECE($GET(^AUTTAREA(X,0),"UNDEFINED"),U,3)_$EXTRACT($PIECE($GET(^AUTTLOC(Y,0),"UNDEFINED"),U,17),2,3)
FMT ;EP
+1 IF '$DATA(X2)
SET X2="2$"
+2 IF '$DATA(X3)
SET X3=0
+3 DO COMMA^%DTC
+4 IF 'X3
SET X=$PIECE(X," ")
+5 WRITE X
+6 KILL X2,X3
+7 QUIT
FUDT ;EP
+1 WRITE !!,*7,"Do not use future dates."
+2 QUIT
FYSEL(X) ;EP
+1 IF '$GET(X)
DO SB1^ACHSFU
+2 NEW MIN,MAX
+3 ; FY selection if in the CHS globals
+4 FOR %=0:0
SET %=$ORDER(ACHSFYWK(DUZ(2),%))
IF '%
QUIT
SET MIN=$SELECT('$DATA(MIN):%,1:MIN)
SET MAX=%
+5 SET O="N^"_MIN_":"_MAX_":0"
SET B=MAX
+6 KILL MIN,MAX
+7 QUIT $$DIR^XBDIR(O,"ENTER FISCAL YEAR",B,"","Invalid FY, Enter FY with all 4 digits","^D SB1^ACHSFU",1)
GDT(JDT) ;EP -JDT-Julian Date, ret Gregorian Date-Ext format
+1 IF '$GET(JDT)
QUIT -1
+2 IF JDT<0
QUIT -1
+3 IF JDT>366
QUIT -1
+4 QUIT $$HTE^XLFDT($PIECE($$FMTH^XLFDT($SELECT(JDT>$$JDT(DT):($EXTRACT(DT,1,3)-1),1:$EXTRACT(DT,1,3))_"0101"),",")+JDT-1)
+5 ;
+6 QUIT "NOT FOUND"
H ;EP -menu header
+1 ;D VIDEO
+2 WRITE @IOF
+3 DO STATUSLN
+4 DO VIDEO
+5 ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ NXT 4 LINES
+6 ;ACHS*3.1*18
SET X=$ORDER(^DIC(9.4,"C","ACHS",0))
+7 ;ACHS*3.1*18
SET V=$GET(^DIC(9.4,X,"VERSION"))
+8 ;ACHS*3.1*18
SET A=$ORDER(^DIC(9.4,X,22,"B",V,0))
+9 ;ACHS*3.1*18
SET P=0
FOR
SET P=$ORDER(^DIC(9.4,X,22,A,"PAH","B",P))
IF P'?1.N.N
QUIT
SET P1=P
+10 SET MENTITLE=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_$PIECE(XQY0,U,2)_IORVOFF
+11 ;W !!!,$$C^XBFUNC($P($T(ACHS+1),";",4)_", "_$$CV^XBFUNC("ACHS")),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(MENTITLE) ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ
+12 ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ
WRITE !!,$$C^XBFUNC($PIECE($TEXT(ACHS+1),";",4)),!,$$C^XBFUNC("VERSION: "_$$CV^XBFUNC("ACHS")_" PATCH "_P1),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(MENTITLE)
+13 QUIT
STATUSLN ;
+1 IF $$VERSION^%ZOSV(1)["NT"
QUIT
+2 SET JOB=$JOB
+3 ;GET CURRENT UCI,VOL
XECUTE ^%ZOSF("UCI")
+4 SET MYLINE="Device: "_$GET(IO)_" Job no.: "_JOB_" "_$SELECT($$OS^ACHS=2:"Windows",1:"Unix")_" Device: "_$GET(IO("ZIO"))_" [UCI,VOL]: "_Y
+5 DO PREP^XGF
+6 DO SAY^XGF(1,1,MYLINE,"R1")
+7 DO CLEAN^XGF
+8 QUIT
+9 ;
HELP(L,R) ;EP -Dis at label L, RTN R
+1 NEW X
+2 WRITE !
+3 FOR %=1:1
SET X=$TEXT(@L+%^@R)
IF ($PIECE(X,";",3)="###")!(X="")
QUIT
Begin DoDot:1
+4 IF $PIECE(X,";",3)="@"
WRITE @($PIECE(X,";",4))
QUIT
+5 WRITE !?4,$PIECE(X,";",3)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
HRN(P,L) ;EP -Ret HRN for DFN-P DUZ(2)-L
+1 ;ITSC/SET/JVK ACHS*3.1*12 ADD BELOW COMMENT FOR IHS/OKCAO/POC PAWNEE BEN. PKG.
+2 ;I +$P($G(^AUTTLOC(DUZ(2),0)),U,1)=505613 Q $$GET1^DIQ(1808000,P_",",1
+3 QUIT $PIECE($GET(^AUPNPAT(P,41,L,0)),U,2)
+4 ;
IM() ;EP - ReT file Imp dir
+1 ;UNIX IMPORT PATH
IF $$OS=1
IF $LENGTH($PIECE($GET(^AUTTSITE(1,1)),U))
QUIT $PIECE($GET(^AUTTSITE(1,1)),U)
+2 ;DOS IMPORT PATH
IF $$OS=2
IF $LENGTH($PIECE($GET(^AUTTSITE(1,1)),U))
QUIT $PIECE($GET(^AUTTSITE(1,1)),U)
+3 QUIT "C:\IMPORT\"
+4 ;
INSURED(DFN,ACHSDATE) ;EP - Does pt have INS on a dt
+1 IF $$MCR^AUPNPAT2(DFN,ACHSDATE)
QUIT 1
+2 IF $$MCD^AUPNPAT2(DFN,ACHSDATE)
QUIT 1
+3 IF $$PI^AUPNPAT2(DFN,ACHSDATE)
QUIT 1
+4 IF $$RRE(DFN,ACHSDATE)
QUIT 1
+5 QUIT 0
+6 ;
JDT(X1,ACHS) ;EP - Given FM dt, Ret Julian Dt. IF ACHS, 3 places.
+1 IF '$DATA(X1)
QUIT -1
+2 IF '(X1?7N)
QUIT -1
+3 SET X2=$EXTRACT(X1,1,3)_"0101"
+4 DO ^%DTC
+5 IF '$GET(ACHS)
QUIT X+1
+6 SET ACHS=X+1
SET ACHS="000"_ACHS
+7 QUIT $EXTRACT(ACHS,$LENGTH(ACHS)-2,$LENGTH(ACHS))
+8 ;
JTF(JDT) ;EP - Given Julian dt ret fm dt
+1 IF '$GET(JDT)
QUIT -1
+2 IF JDT<0
QUIT -1
+3 IF JDT>366
QUIT -1
+4 QUIT $$FMADD^XLFDT($SELECT(JDT>$$JDT(DT):($EXTRACT(DT,1,3)-1),1:$EXTRACT(DT,1,3))_"0101",JDT-1)
+5 ;
L(F,N) ;EP - F = File #; N = Field #.
+1 IF $DATA(ZTQUEUED)!$DATA(IO("S"))!($GET(IOST)'["C-")
QUIT
+2 WRITE !?($LENGTH($PIECE($GET(^DD(F,N,0)),U))+1),"|",$$REPEAT^XLFSTR("-",+$PIECE($PIECE($GET(^DD(F,N,0)),U,5),">",2)),"|"
+3 QUIT
+4 ;
LOC() ;EP - Ret loc
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE($GET(^DIC(4,DUZ(2),0)),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;
LOCK(V,M) ;EP - LOCK var V, mode M (+/-).
+1 IF '$LENGTH($GET(M))
WRITE !,"MODE NOT DEFINED IN LOCK CALL."
DO RTRN
QUIT 0
+2 IF '("+-"[$GET(M))
WRITE !,"BAD MODE PARAMETER IN LOCK CALL."
DO RTRN
QUIT 0
+3 NEW C,L
+4 SET C=0
SET L=10
+5 IF M="-"
GOTO LOCK1
+6 FOR
LOCK +@V:3
IF $TEST
GOTO LOCK2
IF C=L
GOTO LOCK2
DO LOCKMSG
+7 ;FCJ
IF $TEST
QUIT
LOCK1 ;
+1 FOR
LOCK -@V:3
IF $TEST
QUIT
IF C=L
QUIT
DO LOCKMSG
LOCK2 ;
+1 IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE *7,*7,!,$SELECT(M="-":"UN",1:""),"LOCK OF '",V,"' FAILED.",!!,"NOTIFY PROGRAMMER IMMEDIATELY."
DO RTRN
IF 0
+2 QUIT $TEST
+3 ;
LOCKMSG ;
+1 SET C=C+1
+2 IF $DATA(ZTQUEUED)
QUIT
+3 WRITE !,$SELECT(M="-":"UN",1:""),"LOCK of node '",V,"' failed. Retry ",C," of ",L,"."
+4 QUIT
+5 ;
LOGO ;EP - Dis logo-main menu
+1 NEW A,D,I,L,N,R,V
+2 SET L=18
SET R=61
SET D=R-L+1
SET N=R-L-1
+3 ;
+4 ;CHECK FOR IEN OF ACHS PACKAGE ENTRY
SET I=$ORDER(^DIC(9.4,"C","ACHS",0))
+5 IF I=""
WRITE !!,"PACKAGE FILE ENTRY FOR THE 'CONTRACT HEALTH MGMT SYSTEM' IS INCOMPLETE!",!,"INFORM YOUR SITE MANAGER IMMEDIATELY!!"
QUIT
+6 ;
+7 ;CHECK CURRENT VERSION NUMBER
SET V=$GET(^DIC(9.4,I,"VERSION"))
+8 IF V=""
WRITE !!,"PACKAGE FILE ENTRY FOR THE 'CONTRACT HEALTH MGMT SYSTEM' IS INCOMPLETE!",!,"INFORM YOUR SITE MANAGER IMMEDIATELY!!"
+9 ;
+10 ;
SET A=$ORDER(^DIC(9.4,I,22,"B",V,0))
+11 ;'DATE DISTIBUTED'
SET Y=$$FMTE^XLFDT($PIECE($GET(^DIC(9.4,I,22,A,0)),U,2))
+12 ;ACHS*3.1*18 6.30.2010 IHS.OIT.FCJ ADDED LINE, SPLIT NXT LINE AND ADDED PATCH #
SET P=0
FOR
SET P=$ORDER(^DIC(9.4,I,22,A,"PAH","B",P))
IF P'?1.N.N
QUIT
SET P1=P
+13 WRITE @IOF,!,$$C^XBFUNC($$REPEAT^XLFSTR("*",D)),!?L,"*",$$C^XBFUNC("Indian Health Service",N),?R,"*",!?L,"*",$$C^XBFUNC($PIECE($TEXT(ACHS+1),";",4),N),?R,"*"
+14 WRITE !?L,"*",$$C^XBFUNC("Version "_V_" Patch "_P1_", "_Y,N),?R,"*",!,$$C^XBFUNC($$REPEAT^XLFSTR("*",D))
+15 WRITE !!,$$C^XBFUNC($$LOC())
+16 QUIT
NOW ;EP - Set cur time into ACHSTIME
+1 SET ACHSTIME=$$HTE^XLFDT($HOROLOG)
+2 QUIT
OS() ;EP - Ret OS fr ^%ZOSF("OS") or RPMS Site file.
+1 IF $GET(^%ZOSF("OS"))["MSM-UNIX"
QUIT 1
+2 IF $GET(^%ZOSF("OS"))["MSM-PC"
QUIT 2
+3 IF $GET(^%ZOSF("OS"))["OpenM-NT"
IF ($PIECE($GET(^AUTTSITE(1,0)),U,21))
QUIT $PIECE($GET(^AUTTSITE(1,0)),U,21)
+4 IF $PIECE($GET(^AUTTSITE(1,0)),U,21)
QUIT $PIECE($GET(^AUTTSITE(1,0)),U,21)
+5 ; Default is UNIX if "OS" and RPMS SITE can't determine.
QUIT 1
PARM(N,P) ;EP - N = node, P= piece, return the fac parameter value.
+1 QUIT $PIECE($GET(^ACHSF(DUZ(2),N)),U,P)
PB() ;EP - Print/Browse.
+1 QUIT $$DIR^XBDIR("SO^P:PRINT Output;B:BROWSE Output on Screen","Do you want to ","PRINT","","","",2)
PTLK ;EP Stand pt lookup using DIC.
+1 NEW ACHSDUZ2
+2 IF $$PARM(2,5)="Y"
SET ACHSDUZ2=DUZ(2)
SET DUZ(2)=0
+3 ;IHS/OKCAO/POC PAWNEE BEN
+4 IF +$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)=505613
Begin DoDot:1
+5 DO PAWNEE
+6 QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
SET AUPNLK("INAC")=""
+9 IF $GET(DFN)
IF $DATA(^DPT(DFN,0))
SET DIC("B")=$PIECE($GET(^DPT(DFN,0)),U)
+10 DO ^DIC
+11 KILL DFN,DIC,AUPNLK("INAC")
+12 IF Y'<1
SET DFN=+Y
End DoDot:1
+13 ;ITSC/SET/JVK END CHGS
+14 IF $GET(ACHSDUZ2)
SET ACHSYAYA=ACHSDUZ2
SET DUZ(2)=ACHSDUZ2
+15 KILL ACHSYAYA
+16 QUIT
RPL(X,Y,Z) ;EP - In X, Replace Y with Z.
+1 FOR
IF '$FIND(X,Y)
QUIT
SET X=$PIECE(X,Y,1)_Z_$PIECE(X,Y,2,999)
+2 QUIT X
RTRN ;EP - ask usr to press RET
+1 SET ACHSQUIT=0
+2 IF IOST["C-"
IF '$DATA(IO("S"))
SET Y=$$DIR^XBDIR("E","Press RETURN To Continue or ^ to Exit or Cancel...","","","",1)
XECUTE ^%ZOSF("TRMRD")
IF Y=0!(Y=27)!(X=U)
SET ACHSQUIT=1
+3 QUIT
SB(X) ;EP - Strip leading & trailing blanks from X.
+1 XECUTE ^DD("FUNC",$ORDER(^DD("FUNC","B","STRIPBLANKS",0)),1)
+2 QUIT X
TRAN(S,P) ;EP - Ret Transaction data from node S, piece P
+1 ; S will always be 0.
+2 QUIT $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN,S)),U,P)
USR() ;EP - Ret name of current user for ^VA(200.
+1 IF $GET(DUZ)=""
QUIT "DUZ UNDEFINED"
+2 IF $GET(DUZ)=0
QUIT "DUZ IS 0"
+3 IF $DATA(^VA(200,DUZ,0))#2
QUIT $PIECE(^VA(200,DUZ,0),U,1)
+4 QUIT "UNK"
VIDEO ;EP - Set reverse video vars
+1 SET X="IORVON;IORVOFF;IOBON;IOBOFF;IOINORM"
DO ENDR^%ZISS
+2 ;At list vars code for normal follows codes for blinking and reverse.
+3 SET IZZZNORM=$GET(IOINORM)
+4 QUIT
YN ;EP
+1 WRITE !!,"Enter a ""Y"" for YES or an ""N"" for NO."
+2 QUIT
HDR ;EP - Print menu header.
+1 SET X=$ORDER(^DIC(19,"B",X,0))
+2 IF X=""
WRITE !!,"MENU HEADER CANNOT BE PRINTED!"
QUIT
+3 SET X=$PIECE($GET(^DIC(19,X,0)),U,2)
+4 GOTO SHDR
PHDR ;EP - Print parent menu header.
+1 SET X=$PIECE($GET(^DIC(19,+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1),0)),U,2)
+2 IF '$LENGTH(X)
QUIT
+3 SET Y=+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T")-1)
+4 IF Y=0
WRITE !!,"PARENT MENU CANNOT BE FOUND IN XUTL!"
QUIT
+5 SET Y=$PIECE($GET(^DIC(19,Y,0)),U)
+6 IF Y="ACHSMENU"
DO LOGO
QUIT
SHDR ;EP - Screen header.
+1 IF '$DATA(IORVOFF)
DO VIDEO
+2 WRITE @IOF,!,$$C^XBFUNC($PIECE($TEXT(ACHS+1),";",4)),!,$$C^XBFUNC($$LOC()),!,$$C^XBFUNC(X),!!
+3 QUIT
ZEROTH(A,B,C,D,E,F,G,H,I,J,K) ;EP - Return 0th node. A is file #, rest fields.
+1 NEW Z
+2 IF '$GET(A)
QUIT -1
+3 IF '$GET(B)
QUIT -1
+4 FOR Z=67:1:75
IF '$GET(@($CHAR(Z)))
QUIT
SET A=+$PIECE($GET(^DD(A,B,0)),U,2)
SET B=@($CHAR(Z))
+5 IF 'A!('B)
QUIT -1
+6 IF '$DATA(^DD(A,B,0))
QUIT -1
+7 QUIT U_$PIECE($GET(^DD(A,B,0)),U,2)
RRE(P,D) ; Does pt have Railroad insurance on date? 1 = yes, 0 = no.
+1 ; I = IEN in ^AUPNRRE multiple.
+2 IF '$GET(P)
QUIT 0
+3 IF '$GET(D)
QUIT 0
+4 NEW I,Y
+5 SET Y=0
SET U="^"
+6 IF '$DATA(^DPT(P,0))
GOTO RREX
+7 IF $PIECE($GET(^DPT(P,0)),U,19)
GOTO RREX
+8 IF '$DATA(^AUPNPAT(P,0))
GOTO RREX
+9 IF '$DATA(^AUPNRRE(P,11))
GOTO RREX
+10 IF $DATA(^DPT(P,.35))
IF $PIECE(^DPT(P,.35),U)]""
IF $PIECE($GET(^DPT(P,.35)),U)<D
GOTO RREX
+11 SET I=0
+12 FOR
SET I=$ORDER(^AUPNRRE(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+13 IF $PIECE(^AUPNRRE(P,11,I,0),U)>D
QUIT
+14 IF $PIECE($GET(^AUPNRRE(P,11,I,0)),U,2)]""
IF $PIECE($GET(^AUPNRRE(P,11,I,0)),U,2)<D
QUIT
+15 SET Y=1
+16 QUIT
End DoDot:1
RREX ;
+1 QUIT Y
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(^ACHSF(DUZ(2),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
PAWNEE ;IHS/OKCAO/POC PAWNEE BEN PKG
+1 SET DIC=1808000
SET DIC(0)="IQAZEM"
IF +$GET(DFN)
SET DIC("B")=$PIECE($GET(^DPT(DFN,0)),U)
+2 DO ^DIC
KILL DIC
+3 IF $DATA(DUOUT)!(+Y<0)
KILL DFN
QUIT
+4 SET DFN=+Y
SET ACHSBPNO=$PIECE($GET(^AZOPBPP(+Y,0)),U,2)
+5 WRITE !,"PAWNEE BENEFIT NUMBER: ",ACHSBPNO
+6 SET PBEXDT=+$PIECE($GET(^AZOPBPP(+Y,0)),U,3)
SET Y=PBEXDT
XECUTE ^DD("DD")
+7 IF PBEXDT<DT
WRITE !!,*7,"PBPP Eligibility Card Expired on ",Y," --TRANSACTION CANCELLED"
KILL DFN
QUIT
+8 QUIT
