ATXENP.m

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       ;