ACHSUDF ; IHS/ITSC/PMF - FORMAT DOCUMENT DATA FOR PRINT/DISPLAY(1/2) ; [ 01/10/2005 9:14 AM ]
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,11,12,15,16,19,21,27**;JUNE 11,2001;Build 43
;ITSC/SET/JVK ACHS*3.1*7 - USE E-SIG IN DOCUMENT GLOBAL
;ITSC/SET/JVK ACHS*3.1*11 MODIFIED TO DISPLAY MEDICARE PROVIDER
;ITSC/SET/JVK ACHS*3.1*12- 1.4.04 MOD FOR PAWNEE BEN PKG
;ACHS*3.1*16 11/12/2009 IHS.OIT.FCJ CHNG THE DISPLAY OF SSN AND THE DUNS INSTEAD OF UPIN
;ACHS*3.1*27 12/12/2017 IHS.OIT.FCJ MCR DISPLAY FOR THE NEW MBI
;
PTA ;
G FAC:$D(ACHSBLKF)!$D(ACHSSLOC)
S:$D(ACHSDIEN) ACHSPATF=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,20)
S A(1)="Fac: "_$S(ACHSPATF]"":$P(^AUTTLOC(ACHSPATF,0),U,10),1:$P(^AUTTLOC(DUZ(2),0),U,10))
S:$D(ACHSDIEN) ACHSHRN=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,21)
I ACHSHRN<1 S ACHSHRN=$$HRN^ACHS(DFN,DUZ(2))
S ACHSHRN=$E(1000000+ACHSHRN,2,7),A(1)=A(1)_" IHS#: "_ACHSHRN
;
;12/1/00 pmf added for special Pawnee benefit
I $P($G(^AUTTLOC($S($D(ACHSDUZ2):ACHSDUZ2,1:DUZ(2)),0)),U,10)=505613 D PBPPN
;
S T=""
I $D(^AUPNPAT(DFN,11)) S X=$P($G(^AUPNPAT(DFN,11)),U,8) I X,$D(^AUTTTRI(X,0)) S T=$P($G(^AUTTTRI(X,0)),U,2)
S (D,L,A(5))=""
F S D=$O(^AUPNPAT(DFN,51,D)) Q:L&(D="") G P3:D="" S:$D(^(D,0)) L=$P(^(0),U,3)
G P3:'$D(^AUTTCOM(L,0)) S X=$G(^AUTTCOM(L,0)),A(5)=$P(X,U,7)_"-",L=$P(X,U,2)
I L,$D(^AUTTCTY(L,0)) S A(5)=A(5)_$P(^(0),U,3)_"-"
E S A(5)=A(5)_" -"
S X=$P(X,U,3)
I X,$D(^DIC(5,X,0)) S A(5)=A(5)_$P(^(0),U,3)
P3 ;
I $D(^DPT(DFN,0)) D
. S X=$G(^DPT(DFN,0))
. S Y=$P(X,U)
. S A(2)=$P(Y,",")_", "_$P(Y,",",2,99)
. S A(2)=$E(A(2),1,37)
. Q
;
S A(3)=""
G P4:'$D(^DPT(DFN,.11)) S X=$G(^DPT(DFN,.11)),Y=$P(X,U,4),A(3)=Y
I $L(Y)<1 S A(3)=" "
S A(3)=A(3)_", ",Y=$P(X,U,5)
I Y,$D(^DIC(5,Y,0)) S A(3)=A(3)_$P($G(^DIC(5,Y,0)),U,2)_" "
S Y=$P(X,U,6)
I $L(Y)<1 S Y=" "
S A(3)=A(3)_Y
P4 ;
S X=$G(^DPT(DFN,0)),Y=$P(X,U,3),A(4)=$S('Y:" ",1:$E(Y,4,5)_"-"_$E(Y,6,7)_"-"_($E(Y,1,3)+1700))
S Y=$P(X,U,2),A(4)=A(4)_" "_$S(Y="M":"M",Y="F":"F",1:"")_" "_T,ACHSVAL1=$P($G(^AUPNPAT(DFN,11)),U,9) I ACHSVAL1="" S ACHSVAL1=$P($G(^AUPNPAT(DFN,11)),U,10)
D QUANTCV
S A(4)=A(4)_" 00"_Y_" " ;3.1*21 ADDED SPACE
;ACHS*3.1*16 11/12/2009 IHS.OIT.FCJ CHNG THE DISPLAY OF SSN
;I $P($G(^DPT(DFN,0)),U,9)]"" S A(1)=A(1)_" "_$P($G(^DPT(DFN,0)),U,9),A(11)=$P($G(^DPT(DFN,0)),U,9)
I $P($G(^DPT(DFN,0)),U,9)]"" S A(1)=A(1)_" "_"XXXXX"_$E($P($G(^DPT(DFN,0)),U,9),6,9),A(11)="XXXXX"_$E($P($G(^DPT(DFN,0)),U,9),6,9)
I '$D(ACHSDIEN) S A(6)="",A(7)=$G(ACHSDES)
I $D(ACHSDIEN) S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,3)) ACHSFDT=$P(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U) S:$D(^ACHSF(DUZ(2),"D",ACHSDIEN,1)) A(7)=ACHSDES
K ACHSVAL1
Q
;
PBPPN ;
;12/4/00 pmf add this tag for special Pawnee Benefit
;ITSC/SET/JVK ACHS*3.1*12 MOD FOR IHS/OKCAO/KJR
S ACHSBPNO=$P($G(^AZOPBPP(DFN,0)),U,2) I ACHSBPNO="" Q
S A(1)=$E(A(1),1,11)_" BP#: "_ACHSBPNO
Q
;
FAC ;EP - Set CHS Mailing Address into "B" arrary.
Q:'$G(DUZ(2))
Q:'$D(^AUTTLOC(DUZ(2),0))
I $D(^ACHSF(DUZ(2),0)),$P(^(0),U,3)]"" G FAC1
S B(1)=$$LOC^ACHS,X=$G(^AUTTLOC(DUZ(2),0)),B(2)=$P(X,U,12),B(3)=$P(X,U,13),Y=$P(X,U,14)
I Y,$D(^DIC(5,Y,0)) S B(3)=B(3)_$S(B(3)="":"",1:" ")_$P(^(0),U,2)
S B(3)=B(3)_" "_$P(X,U,15)
G FAC2
;
FAC1 ;
S X=$G(^ACHSF(DUZ(2),0)),B(1)=$$LOC^ACHS,B(2)=$P(X,U,2),B(3)=$P(X,U,3),DIC(15)=$P(X,U,11),Y=$P(X,U,4)
I Y,$D(^DIC(5,Y,0)) S B(3)=B(3)_$S(B(3)="":"",1:" ")_$P(^(0),U,2)
S B(3)=B(3)_" "_$P(X,U,5)
FAC2 ;
S B(4)=$P(^AUTTLOC(DUZ(2),0),U,10)
I $$PARM^ACHS(2,25)="Y" S X=$P(^ACHSF(DUZ(2),0),U,12) S:+X>0 B(4)=$P(^AUTTLOC(X,0),U,10)
Q
;
PRO ; Modified from PRO to P9 for Rate/AGR of Providers.
S ACHSAGRP=$G(ACHSAGRP),ACHSCONP=$G(ACHSCONP),ACHSDRG=$G(ACHSDRG)
S ACHSMPP=$G(ACHSMPP)
G P9:'$D(ACHSPROV),P9:'ACHSPROV,P9:'$D(^AUTTVNDR(ACHSPROV,0)) S D(14)=$P(^(0),U,6),X=$P(^(0),U)
S:X["," X=$P(X,",",2)_" "_$P(X,",")
S D(1)=$E($P(X,U),1,35)
G PRO2:'$D(^AUTTVNDR(ACHSPROV,11)) S X=$G(^AUTTVNDR(ACHSPROV,11)),D(4)=$P(X,U),D(6)=$P(X,U,9)
S:$P(X,U,3)?1N.N D(7)=$G(^AUTTVTYP($P(X,U,3),0)),D(7)=$P(D(7),U)
I $P(X,U,2)]"" S D(4)=D(4)_"-"_$P(X,U,2)
I $P(X,U,14)]"" S D("FAX")=$P(X,U,14) ;ACHS*3.1*19 IHS/BJI/WFD 01/11 Adding Fax var
I D(6)'="" S D(6)=$TR(D(6),"()- ","") D
. I D(6)?1N.N S:$L(D(6))>7 D(6)=$E(D(6),1,3)_" "_$E(D(6),4,6)_"-"_$E(D(6),7,13) S:$L(D(6))=7 D(6)=" "_$E(D(6),1,3)_"-"_$E(D(6),4,7) S:$L(D(6))<7 D(6)="" Q
. S:$L(D(6))>7 D(6)=" "_$E(D(6),1,3)_"-"_$E(D(6),4,7)_" "_$E(D(6),8,13)
. S:$L(D(6))<7 D(6)=""
.Q
S D(5)=""
I $D(ACHSDEST) S D(5)=$S(ACHSDEST="I":"IHS",1:"FI")
PRO2 ;
G PRO3:'$D(^AUTTVNDR(ACHSPROV,13)) S X=^AUTTVNDR(ACHSPROV,13),D(2)=$P(X,U),D(3)=$P(X,U,2),Y=$P(X,U,3)
I Y,$D(^DIC(5,Y,0)) S Y=$P(^(0),U,2),D(3)=D(3)_$S(D(3)="":"",1:", ")_Y
S D(3)=D(3)_" "_$P(X,U,4)
PRO3 ;
S ACHSARCO=$P(^ACHSF(DUZ(2),0),U,11)
;ACHS*3.1*16 11.12.2009 IHS.OIT.FCJ TEST FOR DUNS PARAMETER PRINT DUNS INSTEAD OF UPIN
I $$PARM^ACHS(2,13)="Y" S D(8)=$P(^AUTTVNDR(ACHSPROV,0),U,7)
E I $D(^AUTTVNDR(ACHSPROV,17)) S D(8)=$P(^(17),U)
S D(9)=ACHSARCO_"-"
S:ACHSCONP'="" D(10)=13
I ACHSAGRP="" G P9
I '$D(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)) S ACHSAGRP="" G P9
S Z=$S($D(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$P(^(0),U,10),1:"")
I Z="" G P9
I Z="RQ" S D(10)=37,Y=$S($D(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$P(^(0),U,6),1:"") X:Y'="" ^DD("DD") S D(11)=Y
S:Z="PA" D(10)=24
S ACHSDRG=$S(ACHSTYP=1:$S($D(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$P(^(0),U,4),1:""),(ACHSTYP=3)!(ACHSTYP=2):$S($D(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$P(^(0),U,5),1:""))
S D(12)=$S(ACHSDRG="Y":22,ACHSDRG="N":37,1:"")
S D(14)=$S(D(14)="S":3,D(14)="SD":21,D(14)="SW":46,(D(14)="L")!(D(14)="O"):67,1:"")
G P9
;
PRO4 ;THIS SECTION NEVER EXECUTED
13 ;
S D(9)=ACHSARCO_"-"_$E(ACHSCFY,3,4)_"-"
Q
;
24 ;
S D(9)=ACHSARCO_"-PA-"_$E(ACHSRATE,1,2)
Q
;
37 ;
S D(11)=$$FMTE^XLFDT($P(^AUTTVNDR(ACHSPROV,18,ACHSRATE,0),U,6)),D(9)=ACHSARCO_"-"_$E(ACHSRATE,1,2)_"-"
Q
;
P9 ;
Q
;
ALL ;EP.
S:$D(ACHSDES) A(7)=ACHSDES
D PTA,FAC,PRO
G UDF1
;
PRT ;EP.
D PTA:DFN]"",PRO
G UDF1
;
QUANTCV ;
S Y=7
I +ACHSVAL1'>0 G QUANTIHS
S X1=$P(ACHSVAL1,"/",1),X2=$P(ACHSVAL1,"/",2)
I +X2=0 Q
S X=X1/X2
G QUANTCVB
;
QUANTIHS ;
I ACHSVAL1="FULL" S Y=1 Q
I ACHSVAL1="NONE" S Y=5 Q
I ACHSVAL1="UNSPECIFIED" S Y=6 Q
I ACHSVAL1="UNKNOWN" S Y=7 Q
Q:+ACHSVAL1'>0
QUANTCVB ;
S Y=$S(X=1:1,X'<.5:2,X'<.25:3,1:4)
Q
;
UDF1 ;
S X=ACHSESDO,X2="2$",X3=0
D COMMA^%DTC
S E(9)=X,E(7)=$E(ACHSODT,4,5)_"-"_(+$E(ACHSODT,6,7))_"-"_$E(ACHSODT,2,3)
S F(6)="Open Market"
I ACHSCONP,$D(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0)) S F(6)=$P(^(0),U),D(13)=$P(^(0),U,5),D(9)=F(6)
;ITSC/SET/JVK ACHS*3.1*11 GET FOR MEDICARE PROVIDER INFO
I ACHSMPP,$L(ACHSDS)=1 S ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
I ACHSMPP S F(6)="Medicare #:"_$P(ACHSMPN,U),D(13)=ACHSDS,D(9)=$P(ACHSMPN,U)
;
I +ACHSAGRP<1 G A5
S X=$G(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)),Z=$P(X,U,10)
S F(6)=$E($P(X,U,1),1,2)_$S(Z="PA":"-PA-",Z="RQ":"-R-",Z="BPA":"-A-",1:"unkn")
S Y=$E($P(X,U,1),3,6)
S:Z'="PA" F(6)=F(6)_$E(Y,1,4)
S:Z="PA" F(6)=F(6)_$E(Y,2,4)
S:$D(D(9)) D(9)=D(9)_F(6)
;ACHS*3.1*15 IHS.OIT.FCJ ADDED NXT LINE FOR NEW RATE/AGREEMENT FORMATS
I $L($P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U))>6 S (F(6),D(9))=$P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U)
S:ACHSDRG'="N" D(13)=$S(ACHSTYP=1:"IP:"_$P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,2),(ACHSTYP=3)!(ACHSTYP=2):"OP:"_$P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,3))
I $P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,7)'="" S D(15)="PS:"_$P(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,7)
A5 ;
S:ACHSDRG="Y" D(13)="Medicare Rate"
I ACHSOBJC,$D(^ACHSOCC(ACHSOBJC,0)) S %=$P(^(0),U),F(9)=$E(%,1,2)_"."_$E(%,3,4)
I ACHSSCC,$D(^ACHS(3,DUZ(2),1,ACHSSCC,0)) S X=$P(^(0),U),F(8)=$E(X,1,2)_"."_$E(X,3,99)
I ACHSCAN,$D(^ACHS(2,ACHSCAN,0)) S F(7)=$P(^(0),U)
I $D(ACHSHON),ACHSHON,$D(^ACHSF(DUZ(2),"D",ACHSHON,0)) S E(10)=$P(^(0),U,14)_"-"_ACHSFC_"-"_$P(^(0),U)
;ITSC/SET/JVK ACHS*3.1*7 ADD NEXT THREE LINES
I $D(ACHSDIEN),$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)'="" S ACHSSIG=$$GET1^DIQ(200,($P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)),20.3)
I $D(ACHSDIEN),$P(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)="" S ACHSSIG=$S($D(^ACHSF(DUZ(2),"P")):$P(^("P"),U,ACHSTYP),1:"")
I $D(ACHSDIEN),$D(^ACHSF(DUZ(2),"D",ACHSDIEN,0)) S ACHSDEST=$P(^(0),U,17),ACHSDCR=$P(^(0),U,19)
I $D(ACHSEDOS) S A(6)="Est. date-of-svc.: "_$$FMTE^XLFDT(ACHSEDOS)
I $D(ACHSDOS),ACHSDOS S A(8)="Actual DOS: "_$$FMTE^XLFDT(ACHSDOS)
K C,X2,X3
I ACHSTYP=2 S C(1)=" AUTHORIZATION PERIOD",C(2)=" FROM TO",C(3)="---------- ----------",C(4)="" I ACHSFDT]"" S A(6)=$$FMTE^XLFDT(ACHSFDT)_" "_$$FMTE^XLFDT(ACHSTDT),C(4)=A(6),C(5)=$$FMTE^XLFDT(ACHSFDT),C(6)=$$FMTE^XLFDT(ACHSTDT)
I (ACHSTYP=3)!(ACHSTYP=1),ACHSFDT]"" S C(5)=$$FMTE^XLFDT(ACHSFDT),C(4)="Auth. From "_C(5) I ACHSTDT]"" S C(6)=$$FMTE^XLFDT(ACHSTDT),C(4)=C(4)_" to "_C(6)
BLN ;
G MCR:'$D(ACHSBLKF)&'$D(ACHSSLOC)
S L=99,C=0
F I=1:1 S X=$P(ACHSBLT," ",I) Q:X="" S:$L(X)+L>37 C=C+1,L=0,A(C)="" S:A(C)]"" A(C)=A(C)_" " S A(C)=A(C)_X,L=L+$L(X)+1
K Y
G END
;
MCR ; Check/format MediCare eligible.
S A(9)=""
G:'$D(^AUPNMCR(DFN)) RRE
S Y=$$GETMBI^AUPNMBI(DFN,DT,0) ;ACHS*3.1*27
I +Y<1 S Y=+$P($G(^AUPNMCR(DFN,0)),U,3) S Y(1)=$P($G(^AUPNMCR(DFN,0)),U,4) I $D(^AUTTMCS(Y(1))) S Y=Y_$P(^AUTTMCS(Y(1),0),U) ;ACHS*3.1*27 ADDED
;S Y=+$P($G(^AUPNMCR(DFN,0)),U,3),Y(1)=$P($G(^AUPNMCR(DFN,0)),U,4) ;ACHS*3.1*27
I +Y>0 S A(9)="MCR="_Y_" " G MCD ;ACHS*3.1*27
;
RRE ; Check/format RailRoad eligible.
;REWROTE FOR MBI ACHS*3.1*27
;I $D(^AUPNRRE(DFN,0)) S X=$G(^AUPNRRE(DFN,0)),Y=$P(X,U,3),Y(1)=$P(X,U,4),A(9)="RRR=<unknown>"_Y(1) I Y,$D(^AUTTRRP(Y,0)) S A(9)="RRR="_$P($G(^AUTTRRP(Y,0)),U)_Y(1)
G:'$D(^AUPNRRE(DFN)) MCD
S X=$G(^AUPNRRE(DFN,0))
S Y=$$GETMBI^AUPNMBI(DFN,DT,0)
I +Y<1 S Y=$P(X,U,3),Y(1)=$P(X,U,4),A(9)="RRR=<unknown>"_Y(1) I Y,$D(^AUTTRRP(Y,0)) S A(9)="RRR="_$P($G(^AUTTRRP(Y,0)),U)_Y(1)
E S A(9)="RRR="_Y
;
MCD ; Check/format MediCaid eligible.
G PVT:'$D(^AUPNMCD("B",DFN))
S (X,Y)=0
F S Y=$O(^AUPNMCD("B",DFN,Y)) Q:+Y'=Y S X=Y
;I X S A(9)=A(9)_$S($L(A(9)):" ",1:"")_"MCD="_$P(^AUPNMCD(X,0),U,3)_" " ;ACHS*3.1*27
I X S A(9)=A(9)_"MCD="_$P(^AUPNMCD(X,0),U,3)_" " ;ACHS*3.1*27
;
PVT ; Check/format Private ins. eligible.
I $D(^AUPNPRVT(DFN,11)),$O(^(11,0)) S X=0 F S X=$O(^AUPNPRVT(DFN,11,X)) Q:'X S Y=$P(^(X,0),U,7) I Y=""!(Y>ACHSEDOS) S A(9)=A(9)_"PVT INS" Q
S A(10)=$S(ACHSTYP=1:"Est. Days: "_ACHSESDA,((ACHSTYP=3)&($D(E(10)))):"Hosp Ord #: "_E(10),1:"")
END ;
Q
;
ACHSUDF ; IHS/ITSC/PMF - FORMAT DOCUMENT DATA FOR PRINT/DISPLAY(1/2) ; [ 01/10/2005 9:14 AM ]
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**7,11,12,15,16,19,21,27**;JUNE 11,2001;Build 43
+2 ;ITSC/SET/JVK ACHS*3.1*7 - USE E-SIG IN DOCUMENT GLOBAL
+3 ;ITSC/SET/JVK ACHS*3.1*11 MODIFIED TO DISPLAY MEDICARE PROVIDER
+4 ;ITSC/SET/JVK ACHS*3.1*12- 1.4.04 MOD FOR PAWNEE BEN PKG
+5 ;ACHS*3.1*16 11/12/2009 IHS.OIT.FCJ CHNG THE DISPLAY OF SSN AND THE DUNS INSTEAD OF UPIN
+6 ;ACHS*3.1*27 12/12/2017 IHS.OIT.FCJ MCR DISPLAY FOR THE NEW MBI
+7 ;
PTA ;
+1 IF $DATA(ACHSBLKF)!$DATA(ACHSSLOC)
GOTO FAC
+2 IF $DATA(ACHSDIEN)
SET ACHSPATF=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,20)
+3 SET A(1)="Fac: "_$SELECT(ACHSPATF]"":$PIECE(^AUTTLOC(ACHSPATF,0),U,10),1:$PIECE(^AUTTLOC(DUZ(2),0),U,10))
+4 IF $DATA(ACHSDIEN)
SET ACHSHRN=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,21)
+5 IF ACHSHRN<1
SET ACHSHRN=$$HRN^ACHS(DFN,DUZ(2))
+6 SET ACHSHRN=$EXTRACT(1000000+ACHSHRN,2,7)
SET A(1)=A(1)_" IHS#: "_ACHSHRN
+7 ;
+8 ;12/1/00 pmf added for special Pawnee benefit
+9 IF $PIECE($GET(^AUTTLOC($SELECT($DATA(ACHSDUZ2):ACHSDUZ2,1:DUZ(2)),0)),U,10)=505613
DO PBPPN
+10 ;
+11 SET T=""
+12 IF $DATA(^AUPNPAT(DFN,11))
SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,8)
IF X
IF $DATA(^AUTTTRI(X,0))
SET T=$PIECE($GET(^AUTTTRI(X,0)),U,2)
+13 SET (D,L,A(5))=""
+14 FOR
SET D=$ORDER(^AUPNPAT(DFN,51,D))
IF L&(D="")
QUIT
IF D=""
GOTO P3
IF $DATA(^(D,0))
SET L=$PIECE(^(0),U,3)
+15 IF '$DATA(^AUTTCOM(L,0))
GOTO P3
SET X=$GET(^AUTTCOM(L,0))
SET A(5)=$PIECE(X,U,7)_"-"
SET L=$PIECE(X,U,2)
+16 IF L
IF $DATA(^AUTTCTY(L,0))
SET A(5)=A(5)_$PIECE(^(0),U,3)_"-"
+17 IF '$TEST
SET A(5)=A(5)_" -"
+18 SET X=$PIECE(X,U,3)
+19 IF X
IF $DATA(^DIC(5,X,0))
SET A(5)=A(5)_$PIECE(^(0),U,3)
P3 ;
+1 IF $DATA(^DPT(DFN,0))
Begin DoDot:1
+2 SET X=$GET(^DPT(DFN,0))
+3 SET Y=$PIECE(X,U)
+4 SET A(2)=$PIECE(Y,",")_", "_$PIECE(Y,",",2,99)
+5 SET A(2)=$EXTRACT(A(2),1,37)
+6 QUIT
End DoDot:1
+7 ;
+8 SET A(3)=""
+9 IF '$DATA(^DPT(DFN,.11))
GOTO P4
SET X=$GET(^DPT(DFN,.11))
SET Y=$PIECE(X,U,4)
SET A(3)=Y
+10 IF $LENGTH(Y)<1
SET A(3)=" "
+11 SET A(3)=A(3)_", "
SET Y=$PIECE(X,U,5)
+12 IF Y
IF $DATA(^DIC(5,Y,0))
SET A(3)=A(3)_$PIECE($GET(^DIC(5,Y,0)),U,2)_" "
+13 SET Y=$PIECE(X,U,6)
+14 IF $LENGTH(Y)<1
SET Y=" "
+15 SET A(3)=A(3)_Y
P4 ;
+1 SET X=$GET(^DPT(DFN,0))
SET Y=$PIECE(X,U,3)
SET A(4)=$SELECT('Y:" ",1:$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,7)_"-"_($EXTRACT(Y,1,3)+1700))
+2 SET Y=$PIECE(X,U,2)
SET A(4)=A(4)_" "_$SELECT(Y="M":"M",Y="F":"F",1:"")_" "_T
SET ACHSVAL1=$PIECE($GET(^AUPNPAT(DFN,11)),U,9)
IF ACHSVAL1=""
SET ACHSVAL1=$PIECE($GET(^AUPNPAT(DFN,11)),U,10)
+3 DO QUANTCV
+4 ;3.1*21 ADDED SPACE
SET A(4)=A(4)_" 00"_Y_" "
+5 ;ACHS*3.1*16 11/12/2009 IHS.OIT.FCJ CHNG THE DISPLAY OF SSN
+6 ;I $P($G(^DPT(DFN,0)),U,9)]"" S A(1)=A(1)_" "_$P($G(^DPT(DFN,0)),U,9),A(11)=$P($G(^DPT(DFN,0)),U,9)
+7 IF $PIECE($GET(^DPT(DFN,0)),U,9)]""
SET A(1)=A(1)_" "_"XXXXX"_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9)
SET A(11)="XXXXX"_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,9)
+8 IF '$DATA(ACHSDIEN)
SET A(6)=""
SET A(7)=$GET(ACHSDES)
+9 IF $DATA(ACHSDIEN)
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,3))
SET ACHSFDT=$PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,3),U)
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,1))
SET A(7)=ACHSDES
+10 KILL ACHSVAL1
+11 QUIT
+12 ;
PBPPN ;
+1 ;12/4/00 pmf add this tag for special Pawnee Benefit
+2 ;ITSC/SET/JVK ACHS*3.1*12 MOD FOR IHS/OKCAO/KJR
+3 SET ACHSBPNO=$PIECE($GET(^AZOPBPP(DFN,0)),U,2)
IF ACHSBPNO=""
QUIT
+4 SET A(1)=$EXTRACT(A(1),1,11)_" BP#: "_ACHSBPNO
+5 QUIT
+6 ;
FAC ;EP - Set CHS Mailing Address into "B" arrary.
+1 IF '$GET(DUZ(2))
QUIT
+2 IF '$DATA(^AUTTLOC(DUZ(2),0))
QUIT
+3 IF $DATA(^ACHSF(DUZ(2),0))
IF $PIECE(^(0),U,3)]""
GOTO FAC1
+4 SET B(1)=$$LOC^ACHS
SET X=$GET(^AUTTLOC(DUZ(2),0))
SET B(2)=$PIECE(X,U,12)
SET B(3)=$PIECE(X,U,13)
SET Y=$PIECE(X,U,14)
+5 IF Y
IF $DATA(^DIC(5,Y,0))
SET B(3)=B(3)_$SELECT(B(3)="":"",1:" ")_$PIECE(^(0),U,2)
+6 SET B(3)=B(3)_" "_$PIECE(X,U,15)
+7 GOTO FAC2
+8 ;
FAC1 ;
+1 SET X=$GET(^ACHSF(DUZ(2),0))
SET B(1)=$$LOC^ACHS
SET B(2)=$PIECE(X,U,2)
SET B(3)=$PIECE(X,U,3)
SET DIC(15)=$PIECE(X,U,11)
SET Y=$PIECE(X,U,4)
+2 IF Y
IF $DATA(^DIC(5,Y,0))
SET B(3)=B(3)_$SELECT(B(3)="":"",1:" ")_$PIECE(^(0),U,2)
+3 SET B(3)=B(3)_" "_$PIECE(X,U,5)
FAC2 ;
+1 SET B(4)=$PIECE(^AUTTLOC(DUZ(2),0),U,10)
+2 IF $$PARM^ACHS(2,25)="Y"
SET X=$PIECE(^ACHSF(DUZ(2),0),U,12)
IF +X>0
SET B(4)=$PIECE(^AUTTLOC(X,0),U,10)
+3 QUIT
+4 ;
PRO ; Modified from PRO to P9 for Rate/AGR of Providers.
+1 SET ACHSAGRP=$GET(ACHSAGRP)
SET ACHSCONP=$GET(ACHSCONP)
SET ACHSDRG=$GET(ACHSDRG)
+2 SET ACHSMPP=$GET(ACHSMPP)
+3 IF '$DATA(ACHSPROV)
GOTO P9
IF 'ACHSPROV
GOTO P9
IF '$DATA(^AUTTVNDR(ACHSPROV,0))
GOTO P9
SET D(14)=$PIECE(^(0),U,6)
SET X=$PIECE(^(0),U)
+4 IF X[","
SET X=$PIECE(X,",",2)_" "_$PIECE(X,",")
+5 SET D(1)=$EXTRACT($PIECE(X,U),1,35)
+6 IF '$DATA(^AUTTVNDR(ACHSPROV,11))
GOTO PRO2
SET X=$GET(^AUTTVNDR(ACHSPROV,11))
SET D(4)=$PIECE(X,U)
SET D(6)=$PIECE(X,U,9)
+7 IF $PIECE(X,U,3)?1N.N
SET D(7)=$GET(^AUTTVTYP($PIECE(X,U,3),0))
SET D(7)=$PIECE(D(7),U)
+8 IF $PIECE(X,U,2)]""
SET D(4)=D(4)_"-"_$PIECE(X,U,2)
+9 ;ACHS*3.1*19 IHS/BJI/WFD 01/11 Adding Fax var
IF $PIECE(X,U,14)]""
SET D("FAX")=$PIECE(X,U,14)
+10 IF D(6)'=""
SET D(6)=$TRANSLATE(D(6),"()- ","")
Begin DoDot:1
+11 IF D(6)?1N.N
IF $LENGTH(D(6))>7
SET D(6)=$EXTRACT(D(6),1,3)_" "_$EXTRACT(D(6),4,6)_"-"_$EXTRACT(D(6),7,13)
IF $LENGTH(D(6))=7
SET D(6)=" "_$EXTRACT(D(6),1,3)_"-"_$EXTRACT(D(6),4,7)
IF $LENGTH(D(6))<7
SET D(6)=""
QUIT
+12 IF $LENGTH(D(6))>7
SET D(6)=" "_$EXTRACT(D(6),1,3)_"-"_$EXTRACT(D(6),4,7)_" "_$EXTRACT(D(6),8,13)
+13 IF $LENGTH(D(6))<7
SET D(6)=""
+14 QUIT
End DoDot:1
+15 SET D(5)=""
+16 IF $DATA(ACHSDEST)
SET D(5)=$SELECT(ACHSDEST="I":"IHS",1:"FI")
PRO2 ;
+1 IF '$DATA(^AUTTVNDR(ACHSPROV,13))
GOTO PRO3
SET X=^AUTTVNDR(ACHSPROV,13)
SET D(2)=$PIECE(X,U)
SET D(3)=$PIECE(X,U,2)
SET Y=$PIECE(X,U,3)
+2 IF Y
IF $DATA(^DIC(5,Y,0))
SET Y=$PIECE(^(0),U,2)
SET D(3)=D(3)_$SELECT(D(3)="":"",1:", ")_Y
+3 SET D(3)=D(3)_" "_$PIECE(X,U,4)
PRO3 ;
+1 SET ACHSARCO=$PIECE(^ACHSF(DUZ(2),0),U,11)
+2 ;ACHS*3.1*16 11.12.2009 IHS.OIT.FCJ TEST FOR DUNS PARAMETER PRINT DUNS INSTEAD OF UPIN
+3 IF $$PARM^ACHS(2,13)="Y"
SET D(8)=$PIECE(^AUTTVNDR(ACHSPROV,0),U,7)
+4 IF '$TEST
IF $DATA(^AUTTVNDR(ACHSPROV,17))
SET D(8)=$PIECE(^(17),U)
+5 SET D(9)=ACHSARCO_"-"
+6 IF ACHSCONP'=""
SET D(10)=13
+7 IF ACHSAGRP=""
GOTO P9
+8 IF '$DATA(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0))
SET ACHSAGRP=""
GOTO P9
+9 SET Z=$SELECT($DATA(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$PIECE(^(0),U,10),1:"")
+10 IF Z=""
GOTO P9
+11 IF Z="RQ"
SET D(10)=37
SET Y=$SELECT($DATA(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$PIECE(^(0),U,6),1:"")
IF Y'=""
XECUTE ^DD("DD")
SET D(11)=Y
+12 IF Z="PA"
SET D(10)=24
+13 SET ACHSDRG=$SELECT(ACHSTYP=1:$SELECT($DATA(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$PIECE(^(0),U,4),1:""),(ACHSTYP=3)!(ACHSTYP=2):$SELECT($DATA(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0)):$PIECE(^(0),U,5),1:""))
+14 SET D(12)=$SELECT(ACHSDRG="Y":22,ACHSDRG="N":37,1:"")
+15 SET D(14)=$SELECT(D(14)="S":3,D(14)="SD":21,D(14)="SW":46,(D(14)="L")!(D(14)="O"):67,1:"")
+16 GOTO P9
+17 ;
PRO4 ;THIS SECTION NEVER EXECUTED
13 ;
+1 SET D(9)=ACHSARCO_"-"_$EXTRACT(ACHSCFY,3,4)_"-"
+2 QUIT
+3 ;
24 ;
+1 SET D(9)=ACHSARCO_"-PA-"_$EXTRACT(ACHSRATE,1,2)
+2 QUIT
+3 ;
37 ;
+1 SET D(11)=$$FMTE^XLFDT($PIECE(^AUTTVNDR(ACHSPROV,18,ACHSRATE,0),U,6))
SET D(9)=ACHSARCO_"-"_$EXTRACT(ACHSRATE,1,2)_"-"
+2 QUIT
+3 ;
P9 ;
+1 QUIT
+2 ;
ALL ;EP.
+1 IF $DATA(ACHSDES)
SET A(7)=ACHSDES
+2 DO PTA
DO FAC
DO PRO
+3 GOTO UDF1
+4 ;
PRT ;EP.
+1 IF DFN]""
DO PTA
DO PRO
+2 GOTO UDF1
+3 ;
QUANTCV ;
+1 SET Y=7
+2 IF +ACHSVAL1'>0
GOTO QUANTIHS
+3 SET X1=$PIECE(ACHSVAL1,"/",1)
SET X2=$PIECE(ACHSVAL1,"/",2)
+4 IF +X2=0
QUIT
+5 SET X=X1/X2
+6 GOTO QUANTCVB
+7 ;
QUANTIHS ;
+1 IF ACHSVAL1="FULL"
SET Y=1
QUIT
+2 IF ACHSVAL1="NONE"
SET Y=5
QUIT
+3 IF ACHSVAL1="UNSPECIFIED"
SET Y=6
QUIT
+4 IF ACHSVAL1="UNKNOWN"
SET Y=7
QUIT
+5 IF +ACHSVAL1'>0
QUIT
QUANTCVB ;
+1 SET Y=$SELECT(X=1:1,X'<.5:2,X'<.25:3,1:4)
+2 QUIT
+3 ;
UDF1 ;
+1 SET X=ACHSESDO
SET X2="2$"
SET X3=0
+2 DO COMMA^%DTC
+3 SET E(9)=X
SET E(7)=$EXTRACT(ACHSODT,4,5)_"-"_(+$EXTRACT(ACHSODT,6,7))_"-"_$EXTRACT(ACHSODT,2,3)
+4 SET F(6)="Open Market"
+5 IF ACHSCONP
IF $DATA(^AUTTVNDR(ACHSPROV,"CN",ACHSCONP,0))
SET F(6)=$PIECE(^(0),U)
SET D(13)=$PIECE(^(0),U,5)
SET D(9)=F(6)
+6 ;ITSC/SET/JVK ACHS*3.1*11 GET FOR MEDICARE PROVIDER INFO
+7 IF ACHSMPP
IF $LENGTH(ACHSDS)=1
SET ACHSDS=$$EXTSET^XBFUNC(9999999.112303,2,ACHSDS)
+8 IF ACHSMPP
SET F(6)="Medicare #:"_$PIECE(ACHSMPN,U)
SET D(13)=ACHSDS
SET D(9)=$PIECE(ACHSMPN,U)
+9 ;
+10 IF +ACHSAGRP<1
GOTO A5
+11 SET X=$GET(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0))
SET Z=$PIECE(X,U,10)
+12 SET F(6)=$EXTRACT($PIECE(X,U,1),1,2)_$SELECT(Z="PA":"-PA-",Z="RQ":"-R-",Z="BPA":"-A-",1:"unkn")
+13 SET Y=$EXTRACT($PIECE(X,U,1),3,6)
+14 IF Z'="PA"
SET F(6)=F(6)_$EXTRACT(Y,1,4)
+15 IF Z="PA"
SET F(6)=F(6)_$EXTRACT(Y,2,4)
+16 IF $DATA(D(9))
SET D(9)=D(9)_F(6)
+17 ;ACHS*3.1*15 IHS.OIT.FCJ ADDED NXT LINE FOR NEW RATE/AGREEMENT FORMATS
+18 IF $LENGTH($PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U))>6
SET (F(6),D(9))=$PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U)
+19 IF ACHSDRG'="N"
SET D(13)=$SELECT(ACHSTYP=1:"IP:"_$PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,2),(ACHSTYP=3)!(ACHSTYP=2):"OP:"_$PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,3))
+20 IF $PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,7)'=""
SET D(15)="PS:"_$PIECE(^AUTTVNDR(ACHSPROV,18,ACHSAGRP,0),U,7)
A5 ;
+1 IF ACHSDRG="Y"
SET D(13)="Medicare Rate"
+2 IF ACHSOBJC
IF $DATA(^ACHSOCC(ACHSOBJC,0))
SET %=$PIECE(^(0),U)
SET F(9)=$EXTRACT(%,1,2)_"."_$EXTRACT(%,3,4)
+3 IF ACHSSCC
IF $DATA(^ACHS(3,DUZ(2),1,ACHSSCC,0))
SET X=$PIECE(^(0),U)
SET F(8)=$EXTRACT(X,1,2)_"."_$EXTRACT(X,3,99)
+4 IF ACHSCAN
IF $DATA(^ACHS(2,ACHSCAN,0))
SET F(7)=$PIECE(^(0),U)
+5 IF $DATA(ACHSHON)
IF ACHSHON
IF $DATA(^ACHSF(DUZ(2),"D",ACHSHON,0))
SET E(10)=$PIECE(^(0),U,14)_"-"_ACHSFC_"-"_$PIECE(^(0),U)
+6 ;ITSC/SET/JVK ACHS*3.1*7 ADD NEXT THREE LINES
+7 IF $DATA(ACHSDIEN)
IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)'=""
SET ACHSSIG=$$GET1^DIQ(200,($PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)),20.3)
+8 IF $DATA(ACHSDIEN)
IF $PIECE(^ACHSF(DUZ(2),"D",ACHSDIEN,0),U,24)=""
SET ACHSSIG=$SELECT($DATA(^ACHSF(DUZ(2),"P")):$PIECE(^("P"),U,ACHSTYP),1:"")
+9 IF $DATA(ACHSDIEN)
IF $DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,0))
SET ACHSDEST=$PIECE(^(0),U,17)
SET ACHSDCR=$PIECE(^(0),U,19)
+10 IF $DATA(ACHSEDOS)
SET A(6)="Est. date-of-svc.: "_$$FMTE^XLFDT(ACHSEDOS)
+11 IF $DATA(ACHSDOS)
IF ACHSDOS
SET A(8)="Actual DOS: "_$$FMTE^XLFDT(ACHSDOS)
+12 KILL C,X2,X3
+13 IF ACHSTYP=2
SET C(1)=" AUTHORIZATION PERIOD"
SET C(2)=" FROM TO"
SET C(3)="---------- ----------"
SET C(4)=""
IF ACHSFDT]""
SET A(6)=$$FMTE^XLFDT(ACHSFDT)_" "_$$FMTE^XLFDT(ACHSTDT)
SET C(4)=A(6)
SET C(5)=$$FMTE^XLFDT(ACHSFDT)
SET C(6)=$$FMTE^XLFDT(ACHSTDT)
+14 IF (ACHSTYP=3)!(ACHSTYP=1)
IF ACHSFDT]""
SET C(5)=$$FMTE^XLFDT(ACHSFDT)
SET C(4)="Auth. From "_C(5)
IF ACHSTDT]""
SET C(6)=$$FMTE^XLFDT(ACHSTDT)
SET C(4)=C(4)_" to "_C(6)
BLN ;
+1 IF '$DATA(ACHSBLKF)&'$DATA(ACHSSLOC)
GOTO MCR
+2 SET L=99
SET C=0
+3 FOR I=1:1
SET X=$PIECE(ACHSBLT," ",I)
IF X=""
QUIT
IF $LENGTH(X)+L>37
SET C=C+1
SET L=0
SET A(C)=""
IF A(C)]""
SET A(C)=A(C)_" "
SET A(C)=A(C)_X
SET L=L+$LENGTH(X)+1
+4 KILL Y
+5 GOTO END
+6 ;
MCR ; Check/format MediCare eligible.
+1 SET A(9)=""
+2 IF '$DATA(^AUPNMCR(DFN))
GOTO RRE
+3 ;ACHS*3.1*27
SET Y=$$GETMBI^AUPNMBI(DFN,DT,0)
+4 ;ACHS*3.1*27 ADDED
IF +Y<1
SET Y=+$PIECE($GET(^AUPNMCR(DFN,0)),U,3)
SET Y(1)=$PIECE($GET(^AUPNMCR(DFN,0)),U,4)
IF $DATA(^AUTTMCS(Y(1)))
SET Y=Y_$PIECE(^AUTTMCS(Y(1),0),U)
+5 ;S Y=+$P($G(^AUPNMCR(DFN,0)),U,3),Y(1)=$P($G(^AUPNMCR(DFN,0)),U,4) ;ACHS*3.1*27
+6 ;ACHS*3.1*27
IF +Y>0
SET A(9)="MCR="_Y_" "
GOTO MCD
+7 ;
RRE ; Check/format RailRoad eligible.
+1 ;REWROTE FOR MBI ACHS*3.1*27
+2 ;I $D(^AUPNRRE(DFN,0)) S X=$G(^AUPNRRE(DFN,0)),Y=$P(X,U,3),Y(1)=$P(X,U,4),A(9)="RRR=<unknown>"_Y(1) I Y,$D(^AUTTRRP(Y,0)) S A(9)="RRR="_$P($G(^AUTTRRP(Y,0)),U)_Y(1)
+3 IF '$DATA(^AUPNRRE(DFN))
GOTO MCD
+4 SET X=$GET(^AUPNRRE(DFN,0))
+5 SET Y=$$GETMBI^AUPNMBI(DFN,DT,0)
+6 IF +Y<1
SET Y=$PIECE(X,U,3)
SET Y(1)=$PIECE(X,U,4)
SET A(9)="RRR=<unknown>"_Y(1)
IF Y
IF $DATA(^AUTTRRP(Y,0))
SET A(9)="RRR="_$PIECE($GET(^AUTTRRP(Y,0)),U)_Y(1)
+7 IF '$TEST
SET A(9)="RRR="_Y
+8 ;
MCD ; Check/format MediCaid eligible.
+1 IF '$DATA(^AUPNMCD("B",DFN))
GOTO PVT
+2 SET (X,Y)=0
+3 FOR
SET Y=$ORDER(^AUPNMCD("B",DFN,Y))
IF +Y'=Y
QUIT
SET X=Y
+4 ;I X S A(9)=A(9)_$S($L(A(9)):" ",1:"")_"MCD="_$P(^AUPNMCD(X,0),U,3)_" " ;ACHS*3.1*27
+5 ;ACHS*3.1*27
IF X
SET A(9)=A(9)_"MCD="_$PIECE(^AUPNMCD(X,0),U,3)_" "
+6 ;
PVT ; Check/format Private ins. eligible.
+1 IF $DATA(^AUPNPRVT(DFN,11))
IF $ORDER(^(11,0))
SET X=0
FOR
SET X=$ORDER(^AUPNPRVT(DFN,11,X))
IF 'X
QUIT
SET Y=$PIECE(^(X,0),U,7)
IF Y=""!(Y>ACHSEDOS)
SET A(9)=A(9)_"PVT INS"
QUIT
+2 SET A(10)=$SELECT(ACHSTYP=1:"Est. Days: "_ACHSESDA,((ACHSTYP=3)&($DATA(E(10)))):"Hosp Ord #: "_E(10),1:"")
END ;
+1 QUIT
+2 ;
