AGTXALL ;IHS/ASDS/EFG - EXPORT ALL REG DATA ;9:58 AM 19 Oct 2010
;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
;
Q:'$$CHK^AGTXALL1
D HOME^%ZIS,HELP^XBHELP("INTRO","AGTXALL"),HIST
Q:'$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed with the extract of patient demographics for the NPIRS re-load (Y/N)")
NEW AGIN01
S AGIN01=$$NOW^XLFDT
S AGTMP="^AGTXDATA" K @AGTMP
NEW DFN,AGDONE,AGID,AGP3,DX,DY,AGSITE,AGN11,AGDPT0,AGPAT0,T,AGZTQUED
NEW AG,AGRCT,AGOUTFLG,AGROUT,AGTXRGSV,AGIN03,AGIN06,AGBAD16,AGBAD26,AGBAD51
S (AGIN03,AGIN06,AGLDAT,AGROUT,AGOUTFLG,AG("TOT"),DFN,AGBAD16,AGBAD26,AGBAD51)=0,AGFDAT=9999999,AGP3=$P(^AUPNPAT(0),U,3),(AGTXALL,AG("MODCODE"))=1
S AGTXRGSV=$P(^AUTTAREA($P(^AUTTLOC($P(^AUTTSITE(1,0),U),0),U,4),0),U,3),AGTXSITE=$P(^AUTTSITE(1,0),U)
F %=1:1:8 S AG("TOT",%)=0
S DX=$X,DY=$Y+1
F S DFN=$O(^AUPNPAT(DFN)) Q:'DFN D I '(DFN#1000),'$D(ZTQUEUED) X IOXY W "On IEN ",DFN," of ",AGP3," in ^AUPNPAT(..."
. Q:'$D(^DPT(DFN))
. Q:$P(^DPT(DFN,0),U,19) ;merged pt
. S (AGDONE,AGSITE)=0
. F S AGSITE=$O(^AUPNPAT(DFN,41,AGSITE)) Q:'AGSITE D Q:AGDONE
.. I $L($P(^AUPNPAT(DFN,41,AGSITE,0),U,5)) Q:"DM"[$P(^(0),U,5) ; deleted or merged patient
.. KILL T
.. S AG("SITE")=AGSITE,AGRCT=DFN,AGID=$$UID^AGTXID(DFN)
.. I $D(^AGFAC("AC",AGTXSITE)),$D(^AUPNPAT(DFN,41,AGTXSITE,0)) S %=$P(^(0),U,5) I ((%="")!(%="I")) S AG("SITE")=AGTXSITE
.. Q:'$D(^AGFAC("AC",AG("SITE")))
.. ;IHS/SD/TPF AG*7.1*1 IM19329
.. S FIXLIST(DFN)="",NOMSG=1
.. D FIXALL^AGDATA(.FIXLIST,NOMSG)
.. K NOMSG
.. ;END NEW CODE
.. D ALL^AGTX1
.. S AGDPT0=$G(^DPT(DFN,0)),AGPAT0=$G(^AUPNPAT(DFN,0)),AGN11=$G(^AUPNPAT(DFN,11))
.. D RG6,RG7,RG8
.. S AGDONE=1 ;pt is done, one and only one time
.. S AGIN03=AGIN03+1
.. I $P(AGPAT0,U,2),$P(AGPAT0,U,2)<AGFDAT S AGFDAT=$P(AGPAT0,U,2)
.. I $P(AGPAT0,U,2)>AGLDAT S AGLDAT=$P(AGPAT0,U,2)
..Q
.Q
KILL T
S AG("T")=AGIN03,AG("TOT")=AGROUT,AGFDATE=AGFDAT,AGLDATE=AGLDAT
D ALL^AGTX4,^AGVAR,EN^XBVK("XB")
S AGZTQUED=$D(ZTQUEUED),ZTQUEUED=1,AGOPT(17)="N"
S XBQTO="-il regftp:sa3df4gh "_$P($T(DW),";",3)
D ^AGTXTAPE
KILL:'AGZTQUED ZTQUEUED
I $G(XBFLG)=-1 W:'$D(ZTQUEUED) !!,XBFLG(1)
E W:'$D(ZTQUEUED) !,"Comprehensive Export file queued to be sent to ",$P($T(DW),";",3),"...",!
D EN^XBVK("AG"),EN^XBVK("XB")
S AGTMP="^AGTXDATA" K @AGTMP
Q
RG6 ;
NEW I
S I=0
F S I=$O(^AUPNPAT(DFN,51,I)) Q:'I S %=^(I,0),T(6)="RG6"_U_U_($P(%,U,1)+17000000)_U,%=$P(%,U,3) S:% %=$P($G(^AUTTCOM(%,0)),U,8),T(6)=T(6)_$E(%,5,7)_$E(%,3,4)_$E(%,1,2) D SET(6)
Q
RG7 ;
NEW I
S I=0,T(7)="RG7"
F S I=$O(^DPT(DFN,.01,I)) Q:'I S $P(T(7),U,3,5)=$P($$NAMECVT($P(^(I,0),U)),U,1,3) D SET(7)
Q
RG8 ;EP - To export RG8s for regular exports.
I '$G(AGTXALL) S AGDPT0=$G(^DPT(DFN,0)),AGPAT0=$G(^AUPNPAT(DFN,0)),AGN11=$G(^AUPNPAT(DFN,11))
NEW C,D,I,O,S,N
;MediCARE
S I=0
F S I=$O(^AUPNMCR(DFN,11,I)) Q:'I S %=^(I,0),D(9999999-$P(%,U,2),I)=%
D XI(.D)
S D=0,AG0=$G(^AUPNMCR(DFN,0)),AG21=$G(^AUPNMCR(DFN,21))
F S D=$O(D(D)) Q:'D S I=0 F S I=$O(D(D,I)) Q:'I D D SET(8)
. ;S %=^AUPNMCR(DFN,11,I,0)
. ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 IM19329
. S %=$G(^AUPNMCR(DFN,11,I,0))
. Q:%=""!($P(%,U)="")
. ;END NEW CODE
. S T(8)="RG8"_U_U_"MCR"_U_$S($P(%,U,1):($P(%,U,1)+17000000),1:"")_U_$S($P(%,U,2):($P(%,U,2)+17000000),1:"")_U_$P(%,U,3)
. Q:'(D(D,I)="ALL")
. I $P(AG0,U,2) S $P(T(8),U,7)=$P($G(^AUTNINS($P(AG0,U,2),0)),U,1),$P(T(8),U,8)=$P($G(^AUTNINS($P(AG0,U,2),0)),U,7)
. S $P(T(8),U,9)=$P(AG0,U,3)
. I $P(AG0,U,4) S $P(T(8),U,10)=$P($G(^AUTTMCS($P(AG0,U,4),0)),U,1)
. S $P(T(8),U,11,13)=$P($$NAMECVT($P(AGDPT0,U)),U,1,3)
. I $L($P(AG21,U,1)),'($P(AG21,U,1)="SAME") S $P(T(8),U,19,21)=$P($$NAMECVT($P(AG21,U,1)),U,1,3),$P(T(8),U,29)=$P(AG21,U,1) I 1
. E S $P(T(8),U,19,21)=$P(T(8),U,11,13)
. I $P(AG21,U,2) S $P(T(8),U,14)=$P(AG21,U,2)+17000000
. I $P(AG0,U,5) S $P(T(8),U,26)=$P(AG0,U,5)+17000000
.Q
KILL AG0,AG21
;Railroad
KILL D
S I=0
F S I=$O(^AUPNRRE(DFN,11,I)) Q:'I S %=^(I,0),D(9999999-$P(%,U,2),I)=%
D XI(.D)
S D=0,AG0=$G(^AUPNRRE(DFN,0)),AG21=$G(^AUPNRRE(DFN,21))
F S D=$O(D(D)) Q:'D S I=0 F S I=$O(D(D,I)) Q:'I D D SET(8)
. ;S %=^AUPNRRE(DFN,11,I,0)
. ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 IM19329
. S %=$G(^AUPNRRE(DFN,11,I,0))
. Q:%=""!($P(%,U)="")
. ;END NEW CODE
. S T(8)="RG8"_U_U_"RRE"_U_$S($P(%,U,1):($P(%,U,1)+17000000),1:"")_U_$S($P(%,U,2):($P(%,U,2)+17000000),1:"")_U_$P(%,U,3)
. Q:'(D(D,I)="ALL")
. I $P(AG0,U,2) S $P(T(8),U,7)=$P($G(^AUTNINS($P(AG0,U,2),0)),U,1),$P(T(8),U,8)=$P($G(^AUTNINS($P(AG0,U,2),0)),U,7)
. S $P(T(8),U,9)=$P(AG0,U,4)
. I $P(AG0,U,3) S $P(T(8),U,10)=$P($G(^AUTTRRP($P(AG0,U,3),0)),U,1)
. S $P(T(8),U,11,13)=$P($$NAMECVT($P(AGDPT0,U)),U,1,3)
. I $L($P(AG21,U,1)),'($P(AG21,U,1)="SAME") S $P(T(8),U,19,21)=$P($$NAMECVT($P(AG21,U,1)),U,1,3),$P(T(8),U,29)=$P(AG21,U,1) I 1
. E S $P(T(8),U,19,21)=$P(T(8),U,11,13)
. I $P(AG21,U,2) S $P(T(8),U,14)=$P(AG21,U,2)+17000000
.Q
KILL AG0,AG21
;Private
KILL D
S I=0
F S I=$O(^AUPNPRVT(DFN,11,I)) Q:'I S %=$P(^(I,0),U,6,7),D(9999999-$P(%,U,2),I)=%
S D=0
F S D=$O(D(D)) Q:'D S I=0 F S I=$O(D(D,I)) Q:'I D D SET(8)
. S %=^AUPNPRVT(DFN,11,I,0)
. ;BEGIN NEW CDEO IHS/SD/TPF AG*7.1*1 IM19329
. S %=$G(^AUPNPRVT(DFN,11,I,0))
. Q:%=""!($P(%,U)="")!($P(%,U,8)="")
. ;END NEW CODE
. S T(8)="RG8"_U_U_"PVT"_U_$S($P(%,U,6):($P(%,U,6)+17000000),1:"")_U_$S($P(%,U,7):($P(%,U,7)+17000000),1:""),S=$P(%,U,8)
. I S S S=$P($G(^AUPN3PPH(S,0)),U,5) I S S $P(T(8),U,6)=$P($G(^AUTTPIC(S,0)),U,1)
. S $P(T(8),U,7)=$P($G(^AUTNINS($P(%,U,1),0)),U,1)
. S $P(T(8),U,8)=$P($G(^AUTNINS($P(%,U,1),0)),U,7)
. I $P(%,U,8) S $P(T(8),U,9)=$P($G(^AUPN3PPH($P(%,U,8),0)),U,4)
. I '$L($P(T(8),U,9)) S $P(T(8),U,9)=$P(%,U,2)
. S $P(T(8),U,11,13)=$P($$NAMECVT($P(AGDPT0,U)),U,1,3)
. I $P(%,U,8),$P($G(^AUPN3PPH($P(%,U,8),0)),U,2) S $P(T(8),U,11,13)=$P($$NAMECVT($P(^DPT($P(^AUPN3PPH($P(%,U,8),0),U,2),0),U)),U,1,3)
. S $P(T(8),U,19,21)=$P(T(8),U,11,13)
. I $P(%,U,8) S $P(T(8),U,19,21)=$P($$NAMECVT($P($G(^AUPN3PPH($P(%,U,8),0)),U,1)),U,1,3)
. I $P(%,U,9) S $P(T(8),U,17)=$P(%,U,9)+17000000
. S $P(T(8),U,18)=$P(%,U,12)
. I $P(%,U,5) S $P(T(8),U,27)=$P($G(^AUTTRLSH($P(%,U,5),0)),U,1)
.Q
;MediCAID
KILL D
S S=0
F S S=$O(^AUPNMCD("AB",DFN,S)) Q:'S S N="" D
. F S N=$O(^AUPNMCD("AB",DFN,S,N)) Q:'$L(N) S D=0 D
.. F S D=$O(^AUPNMCD("AB",DFN,S,N,D)) Q:'D S %=D KILL D S D=%,I=0 D
... F S I=$O(^AUPNMCD(D,11,I)) Q:'I S %=^(I,0),D(9999999-$P(%,U,2),I)=%
... D XI(.D)
... S O=0
... F S O=$O(D(O)) Q:'O S I=0 F S I=$O(D(O,I)) Q:'I D D SET(8)
.... S %=^AUPNMCD(D,11,I,0)
.... S T(8)="RG8"_U_U_"MCD"_U_$S($P(%,U,1):($P(%,U,1)+17000000),1:"")_U_$S($P(%,U,2):($P(%,U,2)+17000000),1:"")_U_$P(%,U,3)
.... Q:'(D(O,I)="ALL")
.... S %=^AUPNMCD(D,0)
.... I $P(%,U,2) S $P(T(8),U,7)=$P($G(^AUTNINS($P(%,U,2),0)),U,1),$P(T(8),U,8)=$P($G(^AUTNINS($P(%,U,2),0)),U,7)
.... S $P(T(8),U,9)=$P(%,U,3)
.... I $P(%,U,9),$P($G(^AUPN3PPH($P(%,U,9),0)),U,2) S $P(T(8),U,11,13)=$P($$NAMECVT($P(^DPT($P(^AUPN3PPH($P(%,U,9),0),U,2),0),U)),U,1,3) I 1
.... E S $P(T(8),U,11,13)=$P($$NAMECVT($P(AGDPT0,U)),U,1,3)
.... I $L($P($G(^AUPNMCD(D,21)),U,1)),'($P(^(21),U,1)="SAME") S $P(T(8),U,19,21)=$P($$NAMECVT($P(^(21),U,1)),U,1,3),$P(T(8),U,29)=$P(^AUPNMCD(D,21),U,1) I 1
.... E S $P(T(8),U,19,21)=$P(T(8),U,11,13)
.... I $P($G(^AUPNMCD(D,21)),U,2) S $P(T(8),U,14)=$P(^(21),U,2)+17000000
.... S $P(T(8),U,15)=$P(%,U,7)
.... I $P(%,U,4) S $P(T(8),U,16)=$P($G(^DIC(5,$P(%,U,4),0)),U,3)
.... I $P(%,U,10) S $P(T(8),U,22)=$P($G(^AUTNINS($P(%,U,10),0)),U,1)
.... S $P(T(8),U,23)=$P(%,U,13)
.... S $P(T(8),U,24)=$P(%,U,11)
.... I $P(%,U,8) S $P(T(8),U,25)=$P(%,U,8)+17000000
.... I $P(%,U,6) S $P(T(8),U,27)=$P($G(^AUTTRLSH($P(%,U,6),0)),U,1)
....Q
...Q
..Q
.Q
Q
XI(D) ;Determine what RG8s should contain all data.
;D is passed array D(xd,IEN)=BD^ED^CT, where xd=9999999-ED
NEW C,E,I
S (C,E)=0
F S E=$O(D(E)) Q:'E S I=0 F S I=$O(D(E,I)) Q:'I D
. I 'C S D(E,I)="ALL",C=1 Q
. I E=9999999 S D(E,I)="ALL" Q
. I $P(D(E,I),U,2)>DT S D(E,I)="ALL"
.Q
Q:$G(AGTXALL)
;For regular exports, only send the "ALL" RG8s.
S E="D"
F S E=$Q(@E) Q:E="" I @E'="ALL" KILL @E
Q
SET(%) ;EP - Write the RG record to ^AGTXDATA(.
I "5678"[% S $P(T(%),U,$S(%=5:20,%=6:5,%=7:6,%=8:28))=$P(^AUTTLOC(AGTXSITE,0),U,10)
S T=$S(%=1:21,%=2:35,%=3:9,%=4:10,%=5:20,%=6:5,%=7:6,%=8:29)
S $P(T(%),U,2)=AGID,$P(T(%),U,T)=$P(T(%),U,T)
S AGROUT=AGROUT+1,^AGTXDATA(AGROUT)=T(%),AG("TOT")=AG("TOT")+1,AG("TOT",%)=AG("TOT",%)+1
Q:'$G(AGTXALL)
S AGIN06=AGIN06+$L(^AGTXDATA(AGROUT))+$L(AGROUT)+11
Q
NAMECVT(%) ;% is the string containing the name.
S %=$P(%,",",1)_U_$P($P(%,",",2)," ",1)_U_$P($P(%,",",2)," ",2)_U_$P(%,",",3)
I $P(%,U,4)]"" S $P(%,U,1)=$P(%,U,1)_" "_$P(%,U,4) ;Suffix
Q % ;LN^FN^MN
INTRO ;;
;;This option extracts all patient demographics for all patients into
;;an export global for sending to NPIRS for the reload. It is similar
;;to the Patient Registration export in format, but differs in kind,
;;because no quality checks are performed for missing or inconsistent
;;data. The resulting export global, ^AGTXDATA(, will be sent to:
DW ;;www.ihs.gov
;;where the data will be used to re-load NPIRS with PtReg information.
;;
;;Historical comprehensive extract info (max 5):
;;
;;Performed Time (sec) Patients Records File Size (bytes)
;;--------------------- ---------- -------- ------- -----------------
;;###
HIST ;
NEW AG,DA
S AG=0
F DA=9999999999:0 S DA=$O(^AGTXST(DUZ(2),1,DA),-1) Q:((DA=0)!(+DA<1)) D Q:AG=5
. S AG(1)=DA_","_DUZ(2)_","
. Q:'$L($$GET1^DIQ(9009063.01,AG(1),23))
. W !?4,$$GET1^DIQ(9009063.01,AG(1),23),?27,$J($$GET1^DIQ(9009063.01,AG(1),24.1),8),$J($$GET1^DIQ(9009063.01,AG(1),21),12),$J($$GET1^DIQ(9009063.01,AG(1),4),9),$J($$GET1^DIQ(9009063.01,AG(1),22),13)
. S AG=AG+1
.Q
Q
AGTXALL ;IHS/ASDS/EFG - EXPORT ALL REG DATA ;9:58 AM 19 Oct 2010
+1 ;;7.1;PATIENT REGISTRATION;**1,2**;JAN 31, 2007
+2 ;
+3 IF '$$CHK^AGTXALL1
QUIT
+4 DO HOME^%ZIS
DO HELP^XBHELP("INTRO","AGTXALL")
DO HIST
+5 IF '$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed with the extract of patient demographics for the NPIRS re-load (Y/N)")
QUIT
+6 NEW AGIN01
+7 SET AGIN01=$$NOW^XLFDT
+8 SET AGTMP="^AGTXDATA"
KILL @AGTMP
+9 NEW DFN,AGDONE,AGID,AGP3,DX,DY,AGSITE,AGN11,AGDPT0,AGPAT0,T,AGZTQUED
+10 NEW AG,AGRCT,AGOUTFLG,AGROUT,AGTXRGSV,AGIN03,AGIN06,AGBAD16,AGBAD26,AGBAD51
+11 SET (AGIN03,AGIN06,AGLDAT,AGROUT,AGOUTFLG,AG("TOT"),DFN,AGBAD16,AGBAD26,AGBAD51)=0
SET AGFDAT=9999999
SET AGP3=$PIECE(^AUPNPAT(0),U,3)
SET (AGTXALL,AG("MODCODE"))=1
+12 SET AGTXRGSV=$PIECE(^AUTTAREA($PIECE(^AUTTLOC($PIECE(^AUTTSITE(1,0),U),0),U,4),0),U,3)
SET AGTXSITE=$PIECE(^AUTTSITE(1,0),U)
+13 FOR %=1:1:8
SET AG("TOT",%)=0
+14 SET DX=$X
SET DY=$Y+1
+15 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+16 IF '$DATA(^DPT(DFN))
QUIT
+17 ;merged pt
IF $PIECE(^DPT(DFN,0),U,19)
QUIT
+18 SET (AGDONE,AGSITE)=0
+19 FOR
SET AGSITE=$ORDER(^AUPNPAT(DFN,41,AGSITE))
IF 'AGSITE
QUIT
Begin DoDot:2
+20 ; deleted or merged patient
IF $LENGTH($PIECE(^AUPNPAT(DFN,41,AGSITE,0),U,5))
IF "DM"[$PIECE(^(0),U,5)
QUIT
+21 KILL T
+22 SET AG("SITE")=AGSITE
SET AGRCT=DFN
SET AGID=$$UID^AGTXID(DFN)
+23 IF $DATA(^AGFAC("AC",AGTXSITE))
IF $DATA(^AUPNPAT(DFN,41,AGTXSITE,0))
SET %=$PIECE(^(0),U,5)
IF ((%="")!(%="I"))
SET AG("SITE")=AGTXSITE
+24 IF '$DATA(^AGFAC("AC",AG("SITE")))
QUIT
+25 ;IHS/SD/TPF AG*7.1*1 IM19329
+26 SET FIXLIST(DFN)=""
SET NOMSG=1
+27 DO FIXALL^AGDATA(.FIXLIST,NOMSG)
+28 KILL NOMSG
+29 ;END NEW CODE
+30 DO ALL^AGTX1
+31 SET AGDPT0=$GET(^DPT(DFN,0))
SET AGPAT0=$GET(^AUPNPAT(DFN,0))
SET AGN11=$GET(^AUPNPAT(DFN,11))
+32 DO RG6
DO RG7
DO RG8
+33 ;pt is done, one and only one time
SET AGDONE=1
+34 SET AGIN03=AGIN03+1
+35 IF $PIECE(AGPAT0,U,2)
IF $PIECE(AGPAT0,U,2)<AGFDAT
SET AGFDAT=$PIECE(AGPAT0,U,2)
+36 IF $PIECE(AGPAT0,U,2)>AGLDAT
SET AGLDAT=$PIECE(AGPAT0,U,2)
+37 QUIT
End DoDot:2
IF AGDONE
QUIT
+38 QUIT
End DoDot:1
IF '(DFN#1000)
IF '$DATA(ZTQUEUED)
XECUTE IOXY
WRITE "On IEN ",DFN," of ",AGP3," in ^AUPNPAT(..."
+39 KILL T
+40 SET AG("T")=AGIN03
SET AG("TOT")=AGROUT
SET AGFDATE=AGFDAT
SET AGLDATE=AGLDAT
+41 DO ALL^AGTX4
DO ^AGVAR
DO EN^XBVK("XB")
+42 SET AGZTQUED=$DATA(ZTQUEUED)
SET ZTQUEUED=1
SET AGOPT(17)="N"
+43 SET XBQTO="-il regftp:sa3df4gh "_$PIECE($TEXT(DW),";",3)
+44 DO ^AGTXTAPE
+45 IF 'AGZTQUED
KILL ZTQUEUED
+46 IF $GET(XBFLG)=-1
IF '$DATA(ZTQUEUED)
WRITE !!,XBFLG(1)
+47 IF '$TEST
IF '$DATA(ZTQUEUED)
WRITE !,"Comprehensive Export file queued to be sent to ",$PIECE($TEXT(DW),";",3),"...",!
+48 DO EN^XBVK("AG")
DO EN^XBVK("XB")
+49 SET AGTMP="^AGTXDATA"
KILL @AGTMP
+50 QUIT
RG6 ;
+1 NEW I
+2 SET I=0
+3 FOR
SET I=$ORDER(^AUPNPAT(DFN,51,I))
IF 'I
QUIT
SET %=^(I,0)
SET T(6)="RG6"_U_U_($PIECE(%,U,1)+17000000)_U
SET %=$PIECE(%,U,3)
IF %
SET %=$PIECE($GET(^AUTTCOM(%,0)),U,8)
SET T(6)=T(6)_$EXTRACT(%,5,7)_$EXTRACT(%,3,4)_$EXTRACT(%,1,2)
DO SET(6)
+4 QUIT
RG7 ;
+1 NEW I
+2 SET I=0
SET T(7)="RG7"
+3 FOR
SET I=$ORDER(^DPT(DFN,.01,I))
IF 'I
QUIT
SET $PIECE(T(7),U,3,5)=$PIECE($$NAMECVT($PIECE(^(I,0),U)),U,1,3)
DO SET(7)
+4 QUIT
RG8 ;EP - To export RG8s for regular exports.
+1 IF '$GET(AGTXALL)
SET AGDPT0=$GET(^DPT(DFN,0))
SET AGPAT0=$GET(^AUPNPAT(DFN,0))
SET AGN11=$GET(^AUPNPAT(DFN,11))
+2 NEW C,D,I,O,S,N
+3 ;MediCARE
+4 SET I=0
+5 FOR
SET I=$ORDER(^AUPNMCR(DFN,11,I))
IF 'I
QUIT
SET %=^(I,0)
SET D(9999999-$PIECE(%,U,2),I)=%
+6 DO XI(.D)
+7 SET D=0
SET AG0=$GET(^AUPNMCR(DFN,0))
SET AG21=$GET(^AUPNMCR(DFN,21))
+8 FOR
SET D=$ORDER(D(D))
IF 'D
QUIT
SET I=0
FOR
SET I=$ORDER(D(D,I))
IF 'I
QUIT
Begin DoDot:1
+9 ;S %=^AUPNMCR(DFN,11,I,0)
+10 ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 IM19329
+11 SET %=$GET(^AUPNMCR(DFN,11,I,0))
+12 IF %=""!($PIECE(%,U)="")
QUIT
+13 ;END NEW CODE
+14 SET T(8)="RG8"_U_U_"MCR"_U_$SELECT($PIECE(%,U,1):($PIECE(%,U,1)+17000000),1:"")_U_$SELECT($PIECE(%,U,2):($PIECE(%,U,2)+17000000),1:"")_U_$PIECE(%,U,3)
+15 IF '(D(D,I)="ALL")
QUIT
+16 IF $PIECE(AG0,U,2)
SET $PIECE(T(8),U,7)=$PIECE($GET(^AUTNINS($PIECE(AG0,U,2),0)),U,1)
SET $PIECE(T(8),U,8)=$PIECE($GET(^AUTNINS($PIECE(AG0,U,2),0)),U,7)
+17 SET $PIECE(T(8),U,9)=$PIECE(AG0,U,3)
+18 IF $PIECE(AG0,U,4)
SET $PIECE(T(8),U,10)=$PIECE($GET(^AUTTMCS($PIECE(AG0,U,4),0)),U,1)
+19 SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(AGDPT0,U)),U,1,3)
+20 IF $LENGTH($PIECE(AG21,U,1))
IF '($PIECE(AG21,U,1)="SAME")
SET $PIECE(T(8),U,19,21)=$PIECE($$NAMECVT($PIECE(AG21,U,1)),U,1,3)
SET $PIECE(T(8),U,29)=$PIECE(AG21,U,1)
IF 1
+21 IF '$TEST
SET $PIECE(T(8),U,19,21)=$PIECE(T(8),U,11,13)
+22 IF $PIECE(AG21,U,2)
SET $PIECE(T(8),U,14)=$PIECE(AG21,U,2)+17000000
+23 IF $PIECE(AG0,U,5)
SET $PIECE(T(8),U,26)=$PIECE(AG0,U,5)+17000000
+24 QUIT
End DoDot:1
DO SET(8)
+25 KILL AG0,AG21
+26 ;Railroad
+27 KILL D
+28 SET I=0
+29 FOR
SET I=$ORDER(^AUPNRRE(DFN,11,I))
IF 'I
QUIT
SET %=^(I,0)
SET D(9999999-$PIECE(%,U,2),I)=%
+30 DO XI(.D)
+31 SET D=0
SET AG0=$GET(^AUPNRRE(DFN,0))
SET AG21=$GET(^AUPNRRE(DFN,21))
+32 FOR
SET D=$ORDER(D(D))
IF 'D
QUIT
SET I=0
FOR
SET I=$ORDER(D(D,I))
IF 'I
QUIT
Begin DoDot:1
+33 ;S %=^AUPNRRE(DFN,11,I,0)
+34 ;BEGIN NEW CODE IHS/SD/TPF AG*7.1*1 IM19329
+35 SET %=$GET(^AUPNRRE(DFN,11,I,0))
+36 IF %=""!($PIECE(%,U)="")
QUIT
+37 ;END NEW CODE
+38 SET T(8)="RG8"_U_U_"RRE"_U_$SELECT($PIECE(%,U,1):($PIECE(%,U,1)+17000000),1:"")_U_$SELECT($PIECE(%,U,2):($PIECE(%,U,2)+17000000),1:"")_U_$PIECE(%,U,3)
+39 IF '(D(D,I)="ALL")
QUIT
+40 IF $PIECE(AG0,U,2)
SET $PIECE(T(8),U,7)=$PIECE($GET(^AUTNINS($PIECE(AG0,U,2),0)),U,1)
SET $PIECE(T(8),U,8)=$PIECE($GET(^AUTNINS($PIECE(AG0,U,2),0)),U,7)
+41 SET $PIECE(T(8),U,9)=$PIECE(AG0,U,4)
+42 IF $PIECE(AG0,U,3)
SET $PIECE(T(8),U,10)=$PIECE($GET(^AUTTRRP($PIECE(AG0,U,3),0)),U,1)
+43 SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(AGDPT0,U)),U,1,3)
+44 IF $LENGTH($PIECE(AG21,U,1))
IF '($PIECE(AG21,U,1)="SAME")
SET $PIECE(T(8),U,19,21)=$PIECE($$NAMECVT($PIECE(AG21,U,1)),U,1,3)
SET $PIECE(T(8),U,29)=$PIECE(AG21,U,1)
IF 1
+45 IF '$TEST
SET $PIECE(T(8),U,19,21)=$PIECE(T(8),U,11,13)
+46 IF $PIECE(AG21,U,2)
SET $PIECE(T(8),U,14)=$PIECE(AG21,U,2)+17000000
+47 QUIT
End DoDot:1
DO SET(8)
+48 KILL AG0,AG21
+49 ;Private
+50 KILL D
+51 SET I=0
+52 FOR
SET I=$ORDER(^AUPNPRVT(DFN,11,I))
IF 'I
QUIT
SET %=$PIECE(^(I,0),U,6,7)
SET D(9999999-$PIECE(%,U,2),I)=%
+53 SET D=0
+54 FOR
SET D=$ORDER(D(D))
IF 'D
QUIT
SET I=0
FOR
SET I=$ORDER(D(D,I))
IF 'I
QUIT
Begin DoDot:1
+55 SET %=^AUPNPRVT(DFN,11,I,0)
+56 ;BEGIN NEW CDEO IHS/SD/TPF AG*7.1*1 IM19329
+57 SET %=$GET(^AUPNPRVT(DFN,11,I,0))
+58 IF %=""!($PIECE(%,U)="")!($PIECE(%,U,8)="")
QUIT
+59 ;END NEW CODE
+60 SET T(8)="RG8"_U_U_"PVT"_U_$SELECT($PIECE(%,U,6):($PIECE(%,U,6)+17000000),1:"")_U_$SELECT($PIECE(%,U,7):($PIECE(%,U,7)+17000000),1:"")
SET S=$PIECE(%,U,8)
+61 IF S
SET S=$PIECE($GET(^AUPN3PPH(S,0)),U,5)
IF S
SET $PIECE(T(8),U,6)=$PIECE($GET(^AUTTPIC(S,0)),U,1)
+62 SET $PIECE(T(8),U,7)=$PIECE($GET(^AUTNINS($PIECE(%,U,1),0)),U,1)
+63 SET $PIECE(T(8),U,8)=$PIECE($GET(^AUTNINS($PIECE(%,U,1),0)),U,7)
+64 IF $PIECE(%,U,8)
SET $PIECE(T(8),U,9)=$PIECE($GET(^AUPN3PPH($PIECE(%,U,8),0)),U,4)
+65 IF '$LENGTH($PIECE(T(8),U,9))
SET $PIECE(T(8),U,9)=$PIECE(%,U,2)
+66 SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(AGDPT0,U)),U,1,3)
+67 IF $PIECE(%,U,8)
IF $PIECE($GET(^AUPN3PPH($PIECE(%,U,8),0)),U,2)
SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(^DPT($PIECE(^AUPN3PPH($PIECE(%,U,8),0),U,2),0),U)),U,1,3)
+68 SET $PIECE(T(8),U,19,21)=$PIECE(T(8),U,11,13)
+69 IF $PIECE(%,U,8)
SET $PIECE(T(8),U,19,21)=$PIECE($$NAMECVT($PIECE($GET(^AUPN3PPH($PIECE(%,U,8),0)),U,1)),U,1,3)
+70 IF $PIECE(%,U,9)
SET $PIECE(T(8),U,17)=$PIECE(%,U,9)+17000000
+71 SET $PIECE(T(8),U,18)=$PIECE(%,U,12)
+72 IF $PIECE(%,U,5)
SET $PIECE(T(8),U,27)=$PIECE($GET(^AUTTRLSH($PIECE(%,U,5),0)),U,1)
+73 QUIT
End DoDot:1
DO SET(8)
+74 ;MediCAID
+75 KILL D
+76 SET S=0
+77 FOR
SET S=$ORDER(^AUPNMCD("AB",DFN,S))
IF 'S
QUIT
SET N=""
Begin DoDot:1
+78 FOR
SET N=$ORDER(^AUPNMCD("AB",DFN,S,N))
IF '$LENGTH(N)
QUIT
SET D=0
Begin DoDot:2
+79 FOR
SET D=$ORDER(^AUPNMCD("AB",DFN,S,N,D))
IF 'D
QUIT
SET %=D
KILL D
SET D=%
SET I=0
Begin DoDot:3
+80 FOR
SET I=$ORDER(^AUPNMCD(D,11,I))
IF 'I
QUIT
SET %=^(I,0)
SET D(9999999-$PIECE(%,U,2),I)=%
+81 DO XI(.D)
+82 SET O=0
+83 FOR
SET O=$ORDER(D(O))
IF 'O
QUIT
SET I=0
FOR
SET I=$ORDER(D(O,I))
IF 'I
QUIT
Begin DoDot:4
+84 SET %=^AUPNMCD(D,11,I,0)
+85 SET T(8)="RG8"_U_U_"MCD"_U_$SELECT($PIECE(%,U,1):($PIECE(%,U,1)+17000000),1:"")_U_$SELECT($PIECE(%,U,2):($PIECE(%,U,2)+17000000),1:"")_U_$PIECE(%,U,3)
+86 IF '(D(O,I)="ALL")
QUIT
+87 SET %=^AUPNMCD(D,0)
+88 IF $PIECE(%,U,2)
SET $PIECE(T(8),U,7)=$PIECE($GET(^AUTNINS($PIECE(%,U,2),0)),U,1)
SET $PIECE(T(8),U,8)=$PIECE($GET(^AUTNINS($PIECE(%,U,2),0)),U,7)
+89 SET $PIECE(T(8),U,9)=$PIECE(%,U,3)
+90 IF $PIECE(%,U,9)
IF $PIECE($GET(^AUPN3PPH($PIECE(%,U,9),0)),U,2)
SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(^DPT($PIECE(^AUPN3PPH($PIECE(%,U,9),0),U,2),0),U)),U,1,3)
IF 1
+91 IF '$TEST
SET $PIECE(T(8),U,11,13)=$PIECE($$NAMECVT($PIECE(AGDPT0,U)),U,1,3)
+92 IF $LENGTH($PIECE($GET(^AUPNMCD(D,21)),U,1))
IF '($PIECE(^(21),U,1)="SAME")
SET $PIECE(T(8),U,19,21)=$PIECE($$NAMECVT($PIECE(^(21),U,1)),U,1,3)
SET $PIECE(T(8),U,29)=$PIECE(^AUPNMCD(D,21),U,1)
IF 1
+93 IF '$TEST
SET $PIECE(T(8),U,19,21)=$PIECE(T(8),U,11,13)
+94 IF $PIECE($GET(^AUPNMCD(D,21)),U,2)
SET $PIECE(T(8),U,14)=$PIECE(^(21),U,2)+17000000
+95 SET $PIECE(T(8),U,15)=$PIECE(%,U,7)
+96 IF $PIECE(%,U,4)
SET $PIECE(T(8),U,16)=$PIECE($GET(^DIC(5,$PIECE(%,U,4),0)),U,3)
+97 IF $PIECE(%,U,10)
SET $PIECE(T(8),U,22)=$PIECE($GET(^AUTNINS($PIECE(%,U,10),0)),U,1)
+98 SET $PIECE(T(8),U,23)=$PIECE(%,U,13)
+99 SET $PIECE(T(8),U,24)=$PIECE(%,U,11)
+100 IF $PIECE(%,U,8)
SET $PIECE(T(8),U,25)=$PIECE(%,U,8)+17000000
+101 IF $PIECE(%,U,6)
SET $PIECE(T(8),U,27)=$PIECE($GET(^AUTTRLSH($PIECE(%,U,6),0)),U,1)
+102 QUIT
End DoDot:4
DO SET(8)
+103 QUIT
End DoDot:3
+104 QUIT
End DoDot:2
+105 QUIT
End DoDot:1
+106 QUIT
XI(D) ;Determine what RG8s should contain all data.
+1 ;D is passed array D(xd,IEN)=BD^ED^CT, where xd=9999999-ED
+2 NEW C,E,I
+3 SET (C,E)=0
+4 FOR
SET E=$ORDER(D(E))
IF 'E
QUIT
SET I=0
FOR
SET I=$ORDER(D(E,I))
IF 'I
QUIT
Begin DoDot:1
+5 IF 'C
SET D(E,I)="ALL"
SET C=1
QUIT
+6 IF E=9999999
SET D(E,I)="ALL"
QUIT
+7 IF $PIECE(D(E,I),U,2)>DT
SET D(E,I)="ALL"
+8 QUIT
End DoDot:1
+9 IF $GET(AGTXALL)
QUIT
+10 ;For regular exports, only send the "ALL" RG8s.
+11 SET E="D"
+12 FOR
SET E=$QUERY(@E)
IF E=""
QUIT
IF @E'="ALL"
KILL @E
+13 QUIT
SET(%) ;EP - Write the RG record to ^AGTXDATA(.
+1 IF "5678"[%
SET $PIECE(T(%),U,$SELECT(%=5:20,%=6:5,%=7:6,%=8:28))=$PIECE(^AUTTLOC(AGTXSITE,0),U,10)
+2 SET T=$SELECT(%=1:21,%=2:35,%=3:9,%=4:10,%=5:20,%=6:5,%=7:6,%=8:29)
+3 SET $PIECE(T(%),U,2)=AGID
SET $PIECE(T(%),U,T)=$PIECE(T(%),U,T)
+4 SET AGROUT=AGROUT+1
SET ^AGTXDATA(AGROUT)=T(%)
SET AG("TOT")=AG("TOT")+1
SET AG("TOT",%)=AG("TOT",%)+1
+5 IF '$GET(AGTXALL)
QUIT
+6 SET AGIN06=AGIN06+$LENGTH(^AGTXDATA(AGROUT))+$LENGTH(AGROUT)+11
+7 QUIT
NAMECVT(%) ;% is the string containing the name.
+1 SET %=$PIECE(%,",",1)_U_$PIECE($PIECE(%,",",2)," ",1)_U_$PIECE($PIECE(%,",",2)," ",2)_U_$PIECE(%,",",3)
+2 ;Suffix
IF $PIECE(%,U,4)]""
SET $PIECE(%,U,1)=$PIECE(%,U,1)_" "_$PIECE(%,U,4)
+3 ;LN^FN^MN
QUIT %
INTRO ;;
+1 ;;This option extracts all patient demographics for all patients into
+2 ;;an export global for sending to NPIRS for the reload. It is similar
+3 ;;to the Patient Registration export in format, but differs in kind,
+4 ;;because no quality checks are performed for missing or inconsistent
+5 ;;data. The resulting export global, ^AGTXDATA(, will be sent to:
DW ;;www.ihs.gov
+1 ;;where the data will be used to re-load NPIRS with PtReg information.
+2 ;;
+3 ;;Historical comprehensive extract info (max 5):
+4 ;;
+5 ;;Performed Time (sec) Patients Records File Size (bytes)
+6 ;;--------------------- ---------- -------- ------- -----------------
+7 ;;###
HIST ;
+1 NEW AG,DA
+2 SET AG=0
+3 FOR DA=9999999999:0
SET DA=$ORDER(^AGTXST(DUZ(2),1,DA),-1)
IF ((DA=0)!(+DA<1))
QUIT
Begin DoDot:1
+4 SET AG(1)=DA_","_DUZ(2)_","
+5 IF '$LENGTH($$GET1^DIQ(9009063.01,AG(1),23))
QUIT
+6 WRITE !?4,$$GET1^DIQ(9009063.01,AG(1),23),?27,$JUSTIFY($$GET1^DIQ(9009063.01,AG(1),24.1),8),$JUSTIFY($$GET1^DIQ(9009063.01,AG(1),21),12),$JUSTIFY($$GET1^DIQ(9009063.01,AG(1),4),9),$JUSTIFY($$GET1^DIQ(9009063.01,AG(1),22),13)
+7 SET AG=AG+1
+8 QUIT
End DoDot:1
IF AG=5
QUIT
+9 QUIT
