ATXENP ; IHS/OHPRD/TMJ - CREATES AND ENTERS PTS INTO PT TAXONOMY FILE ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;
D INIT
D START
D EOJ
Q
;
INIT ;
D ^XBKVAR
S U="^"
Q
;
START ;
K ATXTRT
S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,8)" D ^DIC K DIC
I Y<1 Q
I $O(^ATXPAT(+Y,11,0)) W !,$C(7),"Patients already entered under this taxonomy in the Pt Taxonomy file!" G START
I '$O(^ATXAX(+Y,21,0)) W !,$C(7),"ICD Codes have not been entered into this taxonomy!" G START
S ATXX=+Y
I $D(^TMP("ATXTAX",ATXX)) W !,$C(7),"Taxonomy now",^(ATXX)," Try later." G START
I $P(^ATXAX(ATXX,0),U,6)=""!('$O(^ATXPAT(+Y,11,0))) S DIE="^ATXAX(",DR=".06;.18",DA=ATXX D ^DIE K DIE,DR,DA
I '$P(^ATXAX(ATXX,0),U,6) W !,$C(7),"You have no date for entries to be added to the PT TAXONOMY file.",!,"Entries will not be made until a date is indicated." Q
I $D(Y) Q
I '$D(^ATXPAT(ATXX,0))#2 S DIADD="",DIC="^ATXPAT(",DIC(0)="L",X="`"_ATXX,DIC("DR")=".02////"_DT_";.03////"_DUZ D ^DIC K DIADD,DIC,DR S ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"
I $P(^ATXAX(ATXX,0),U,6)'<(DT+1) Q
D TSKMN
Q
;
TSKMN ;EP
W !!,$C(7),"Entries for this taxonomy into the Pt Taxonomy file, will now occur via Taskman",!,"in background!"
S ^TMP("ATXTAX",ATXX)=" having patients entered into the Pt Taxonomy file."
K ZTSAVE F %="ATXX" S ZTSAVE(%)=""
S ZTRTN="ZTM^ATXENP",ZTDESC="ENTER PTS INTO PT TAX FILE",ZTIO="",ZTDTH=DT D ^%ZTLOAD K ZTSK
Q
;
ZTM ;ENTRY POINT FOR TASKMAN
D DFNS
K ^TMP("ATXTAX",ATXX)
I $D(ZTQUEUED) S ZTREQ="@"
D EOJ
Q
;
DFNS ;
S ATXSS=0 F ATXL=0:0 S ATXSS=$O(^ATXAX(ATXX,21,ATXSS)) Q:ATXSS'=+ATXSS S ATXLOV=$P(^(ATXSS,0),U) S:ATXLOV'[" " ATXLOV=ATXLOV_" " S ATXHIV=$P(^(0),U,2) S:ATXHIV'[" " ATXHIV=ATXHIV_" " D GETVAL ;ACC 1/20/94 PUT IN CHECKS FOR " "
Q
;
GETVAL ;GET RANGE OF DFNS
S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D LOOP
Q:ATXHIV=ATXLOV
F ATXL=0:0 S ATXLOV=$O(^ICD9("BA",ATXLOV)) Q:ATXLOV](ATXHIV) S ATXDFN=$O(^ICD9("BA",ATXLOV,"")) D LOOP
Q
;
LOOP ;GET PTS FROM V POV FILE FOR THIS ICD CODE DFN
Q:ATXDFN=""
S ATXPV=0
F ATXL=0:0 S ATXPV=$O(^AUPNVPOV("B",ATXDFN,ATXPV)) Q:ATXPV'=+ATXPV S ATXPD=$P(^AUPNVPOV(ATXPV,0),U,2) D ADD
Q
;
ADD ;ADDS PTS TO TAXONOMY IN PT TAXONOMY FILE
Q:'$D(^ATXPAT(ATXX,0))#2
S ATXVIS=$P(^AUPNVPOV(ATXPV,0),U,3),ATXVIS=$P($P(^AUPNVSIT(ATXVIS,0),U),".") Q:ATXVIS<$P(^ATXAX(ATXX,0),U,6)
I $D(^ATXPAT(ATXX,11,ATXPD)) S $P(^(0),U,2)=$P(^(ATXPD,0),U,2)+1 Q
S ^ATXPAT(ATXX,11,ATXPD,0)=ATXPD_"^1"
S $P(^ATXPAT(ATXX,11,0),U,3)=ATXPD,$P(^(0),U,4)=$P(^(0),U,4)+1
NEW (DT,DTIME,DUZ,IO,IOF,IOM,IOS,IOSL,IOXY,U,XQDIC,XQPSM,XQY,IOST,XQYO,ZTQUEUED,ATXPD,ATXX) D
. S DA=ATXPD,DA(1)=ATXX,DIK="^ATXPAT(ATXX,11," D IX1^DIK K DIK,DA
Q
;
EOJ ;
K ATXLOV,ATXHIV,ATXLO,ATXHI,ATXPD,ATXPV,ATXX,ATXL,ATXWT,ATXPAT,ATXSS,ATXDFN,ATXVIS
Q
;
ATXENP ; IHS/OHPRD/TMJ - CREATES AND ENTERS PTS INTO PT TAXONOMY FILE ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;
+3 DO INIT
+4 DO START
+5 DO EOJ
+6 QUIT
+7 ;
INIT ;
+1 DO ^XBKVAR
+2 SET U="^"
+3 QUIT
+4 ;
START ;
+1 KILL ATXTRT
+2 SET DIC="^ATXAX("
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,8)"
DO ^DIC
KILL DIC
+3 IF Y<1
QUIT
+4 IF $ORDER(^ATXPAT(+Y,11,0))
WRITE !,$CHAR(7),"Patients already entered under this taxonomy in the Pt Taxonomy file!"
GOTO START
+5 IF '$ORDER(^ATXAX(+Y,21,0))
WRITE !,$CHAR(7),"ICD Codes have not been entered into this taxonomy!"
GOTO START
+6 SET ATXX=+Y
+7 IF $DATA(^TMP("ATXTAX",ATXX))
WRITE !,$CHAR(7),"Taxonomy now",^(ATXX)," Try later."
GOTO START
+8 IF $PIECE(^ATXAX(ATXX,0),U,6)=""!('$ORDER(^ATXPAT(+Y,11,0)))
SET DIE="^ATXAX("
SET DR=".06;.18"
SET DA=ATXX
DO ^DIE
KILL DIE,DR,DA
+9 IF '$PIECE(^ATXAX(ATXX,0),U,6)
WRITE !,$CHAR(7),"You have no date for entries to be added to the PT TAXONOMY file.",!,"Entries will not be made until a date is indicated."
QUIT
+10 IF $DATA(Y)
QUIT
+11 IF '$DATA(^ATXPAT(ATXX,0))#2
SET DIADD=""
SET DIC="^ATXPAT("
SET DIC(0)="L"
SET X="`"_ATXX
SET DIC("DR")=".02////"_DT_";.03////"_DUZ
DO ^DIC
KILL DIADD,DIC,DR
SET ^ATXPAT(ATXX,11,0)="^9002227.01101PA^0^0"
+12 IF $PIECE(^ATXAX(ATXX,0),U,6)'<(DT+1)
QUIT
+13 DO TSKMN
+14 QUIT
+15 ;
TSKMN ;EP
+1 WRITE !!,$CHAR(7),"Entries for this taxonomy into the Pt Taxonomy file, will now occur via Taskman",!,"in background!"
+2 SET ^TMP("ATXTAX",ATXX)=" having patients entered into the Pt Taxonomy file."
+3 KILL ZTSAVE
FOR %="ATXX"
SET ZTSAVE(%)=""
+4 SET ZTRTN="ZTM^ATXENP"
SET ZTDESC="ENTER PTS INTO PT TAX FILE"
SET ZTIO=""
SET ZTDTH=DT
DO ^%ZTLOAD
KILL ZTSK
+5 QUIT
+6 ;
ZTM ;ENTRY POINT FOR TASKMAN
+1 DO DFNS
+2 KILL ^TMP("ATXTAX",ATXX)
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 DO EOJ
+5 QUIT
+6 ;
DFNS ;
+1 ;ACC 1/20/94 PUT IN CHECKS FOR " "
SET ATXSS=0
FOR ATXL=0:0
SET ATXSS=$ORDER(^ATXAX(ATXX,21,ATXSS))
IF ATXSS'=+ATXSS
QUIT
SET ATXLOV=$PIECE(^(ATXSS,0),U)
IF ATXLOV'[" "
SET ATXLOV=ATXLOV_" "
SET ATXHIV=$PIECE(^(0),U,2)
IF ATXHIV'[" "
SET ATXHIV=ATXHIV_" "
DO GETVAL
+2 QUIT
+3 ;
GETVAL ;GET RANGE OF DFNS
+1 SET ATXDFN=$ORDER(^ICD9("BA",ATXLOV,""))
DO LOOP
+2 IF ATXHIV=ATXLOV
QUIT
+3 FOR ATXL=0:0
SET ATXLOV=$ORDER(^ICD9("BA",ATXLOV))
IF ATXLOV](ATXHIV)
QUIT
SET ATXDFN=$ORDER(^ICD9("BA",ATXLOV,""))
DO LOOP
+4 QUIT
+5 ;
LOOP ;GET PTS FROM V POV FILE FOR THIS ICD CODE DFN
+1 IF ATXDFN=""
QUIT
+2 SET ATXPV=0
+3 FOR ATXL=0:0
SET ATXPV=$ORDER(^AUPNVPOV("B",ATXDFN,ATXPV))
IF ATXPV'=+ATXPV
QUIT
SET ATXPD=$PIECE(^AUPNVPOV(ATXPV,0),U,2)
DO ADD
+4 QUIT
+5 ;
ADD ;ADDS PTS TO TAXONOMY IN PT TAXONOMY FILE
+1 IF '$DATA(^ATXPAT(ATXX,0))#2
QUIT
+2 SET ATXVIS=$PIECE(^AUPNVPOV(ATXPV,0),U,3)
SET ATXVIS=$PIECE($PIECE(^AUPNVSIT(ATXVIS,0),U),".")
IF ATXVIS<$PIECE(^ATXAX(ATXX,0),U,6)
QUIT
+3 IF $DATA(^ATXPAT(ATXX,11,ATXPD))
SET $PIECE(^(0),U,2)=$PIECE(^(ATXPD,0),U,2)+1
QUIT
+4 SET ^ATXPAT(ATXX,11,ATXPD,0)=ATXPD_"^1"
+5 SET $PIECE(^ATXPAT(ATXX,11,0),U,3)=ATXPD
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+6 NEW (DT,DTIME,DUZ,IO,IOF,IOM,IOS,IOSL,IOXY,U,XQDIC,XQPSM,XQY,IOST,XQYO,ZTQUEUED,ATXPD,ATXX)
Begin DoDot:1
+7 SET DA=ATXPD
SET DA(1)=ATXX
SET DIK="^ATXPAT(ATXX,11,"
DO IX1^DIK
KILL DIK,DA
End DoDot:1
+8 QUIT
+9 ;
EOJ ;
+1 KILL ATXLOV,ATXHIV,ATXLO,ATXHI,ATXPD,ATXPV,ATXX,ATXL,ATXWT,ATXPAT,ATXSS,ATXDFN,ATXVIS
+2 QUIT
+3 ;
