APCDALGQ.m

APCDALGQ ; IHS/CMI/LAB - PRINT ALLERGY LIST FROM PROBLEM LIST ;

 ;;2.0;IHS PCC SUITE;**5,11**;MAY 14, 2009;Build 58

 ;

START ;

 D XIT

 I '$D(IOF) D HOME^%ZIS

 W @(IOF),!!

 W "*******  LIST OF PATIENTS WITH ALLERGIES ENTERED ONTO THE   *******",!

 W "    ******* PCC PROBLEM LIST IN A SPECIFIED TIME PERIOD *******"

 W !!,"This report will produce a list of patients who have had allergies entered"

 W !,"onto their problem list in a specified date range.  If you are using"

 W !,"this list to populate the Allergy Tracking module you should"

 W !,"first run the Option 'List all patients with Allergies on their"

 W !,"problem list'.  You would use that report to enter the allergies"

 W !,"into the Allergy tracking module.  When you have finished that list"

 W !,"you can use this list to pick up any allergies entered onto the problem"

 W !,"list after you have ran and processed that list.",!

 W !

GETDATES ;

BD ;get beginning date

 W !,"Please enter the date range for which allergies have been entered",!,"onto the problem list.",!

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter beginning Date" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S APCDBD=Y

ED ;get ending date

 W ! S DIR(0)="DA^"_APCDBD_":DT:EP",DIR("A")="Enter ending Date:  " S Y=APCDBD D DD^%DT S Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S APCDED=Y

 S X1=APCDBD,X2=-1 D C^%DTC S APCDSD=X S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y

 ;

ZIS ;

 S XBRC="PROC^APCDALGQ",XBRP="PRINT^APCDALGQ",XBNS="APCD",XBRX="XIT^APCDALGQ"

 D ^XBDBQUE

XIT ;

 D EN^XBVK("APCD")

 D ^XBFMK

 Q

XTMP(N,T) ;EP

 I $G(N)="" Q

 S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T

 Q

 ;

PROC ;EP - entry point for processing

 S APCDJOB=$J,APCDBTH=$H,APCDTOT=0,APCDBT=$H

 D XTMP("APCDALGQ","PCC PROBLEM LIST ALLERGY LIST")

 S APCDET=$H

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D PROC1

 Q

PROC1 ;

 Q:$$DOD^AUPNPAT(DFN)]""  ;no deceased patients

 I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)="I" Q  ;no inactive patients

 ;Q:'$$LASTVD(DFN,APCDBD,APCDED)  ;no visit in time perio

 S APCDX=0 F  S APCDX=$O(^AUPNPROB("AC",DFN,APCDX)) Q:APCDX'=+APCDX  S G=0 D  I G S ^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN,APCDX)=""

 .Q:$P(^AUPNPROB(APCDX,0),U,8)<APCDBD

 .Q:$P(^AUPNPROB(APCDX,0),U,8)>APCDED

 .I $P(^AUPNPROB(APCDX,0),U,12)="D" Q  ;deleted

 .S APCDP=$P($G(^AUPNPROB(APCDX,0)),U)

 .Q:APCDP=""

 .S APCDICD=$P($$ICDDX^ICDEX(APCDP),U,2)

 .Q:APCDICD=""

 .I $P(^AUPNPROB(APCDX,0),U,5)="" Q  ;IHS/CMI/LAB - no narr

 .S APCDSNKA=0

 .I APCDICD="692.3" S G=1 Q

 .I APCDICD="693.0" S G=1 Q

 .I APCDICD="995.0" S G=1 Q

 .I APCDICD=995.2 S G=1 Q

 .I (+APCDICD'<999.4),(+APCDICD'>999.8) S G=1 Q

 .I APCDICD?1"V14."1E S G=1 Q

 .I APCDICD="692.5" S G=1 Q

 .I APCDICD="693.1" S G=1 Q

 .I APCDICD["V15.0" S G=1 Q

 .I $E(APCDICD,1,3)=692,APCDICD'="692.9" S G=1 Q

 .I APCDICD="693.8" S G=1 Q

 .I APCDICD="693.9" S G=1 Q

 .I APCDICD="989.5" S G=1 Q

 .I APCDICD="995.3" S G=1 Q

 .I APCDICD="995.2" S G=1 Q

 .;S N=$P(^AUTNPOV($P(^AUPNPROB(APCDX,0),U,5),0),U) I APCDICD="799.9"!(APCDICD="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCDSNKA=1 S G=1 Q

 .S N=$P(^AUTNPOV($P(^AUPNPROB(APCDX,0),U,5),0),U) I N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCDSNKA=1 S G=1 Q

 Q

LASTVD(P,BDATE,EDATE) ;

 I '$D(^AUPNVSIT("AC",P)) Q ""

 K ^TMP($J,"A")

 S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)

 I '$D(^TMP($J,"A",1)) Q ""

 S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G)  S V=$P(^TMP($J,"A",X),U,5) D

 .Q:'$D(^AUPNVSIT(V,0))

 .Q:'$P(^AUPNVSIT(V,0),U,9)

 .Q:$P(^AUPNVSIT(V,0),U,11)

 .Q:'$D(^AUPNVPRV("AD",V))

 .Q:"SAHOIRCT"'[$P(^AUPNVSIT(V,0),U,7)

 .Q:"V"[$P(^AUPNVSIT(V,0),U,3)

 .S G=1

 .Q

 Q G

PRINT ;

 S APCD80D="-------------------------------------------------------------------------------"

 S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y

 S APCDPG=0

 I '$D(^XTMP("APCDALGQ",APCDJOB,APCDBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE

 D HEAD

 S DFN=0 F  S DFN=$O(^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN)) Q:DFN'=+DFN!($D(APCDQ))  D

 .I $Y>(IOSL-6) D HEAD Q:$D(APCDQ)

 .W !!,$P(^DPT(DFN,0),U),?31,$$HRN^AUPNPAT(DFN,DUZ(2)),?42,$$DOB^AUPNPAT(DFN,"E")

 .W !?3,"DATE ADDED",?17,"DX",?24,"PROVIDER NARRATIVE"

 .W !?3,"----------",?17,"--",?24,"------------------"

 .S APCDP=0 F  S APCDP=$O(^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN,APCDP)) Q:APCDP=""!($D(APCDQ))  D

 ..W !?3,$$VAL^XBDIQ1(9000011,APCDP,.08),?17,$$VAL^XBDIQ1(9000011,APCDP,.01),?24,$$VAL^XBDIQ1(9000011,APCDP,.05)

DONE ;

 K ^XTMP("APCDALGQ",APCDJOB,APCDBTH),APCDJOB,APCDBTH

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

         ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

         ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

HEAD I 'APCDPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCDQ="" Q

HEAD1 ;

 W:$D(IOF) @IOF S APCDPG=APCDPG+1

 W $P(^VA(200,DUZ,0),U,2),?72,"Page ",APCDPG,!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 S X="PATIENTS WITH ALLERGIES OR DOCUMENTED NO KNOWN ALLERGIES ON PCC PROBLEM LIST" W $$CTR(X),!

 S X="ALLERGIES ADDED TO THE PROBLEM:  "_APCDBDD_"  TO  "_APCDEDD W $$CTR(X),!

 W "PATIENT NAME",?31,"CHART #",?45,"DOB",!,APCD80D

 Q

APCDALGQ  ; IHS/CMI/LAB - PRINT ALLERGY LIST FROM PROBLEM LIST ;

 +1       ;;2.0;IHS PCC SUITE;**5,11**;MAY 14, 2009;Build 58

 +2       ;

START     ;

 +1        DO XIT

 +2        IF '$DATA(IOF)

               DO HOME^%ZIS

 +3        WRITE @(IOF),!!

 +4        WRITE "*******  LIST OF PATIENTS WITH ALLERGIES ENTERED ONTO THE   *******",!

 +5        WRITE "    ******* PCC PROBLEM LIST IN A SPECIFIED TIME PERIOD *******"

 +6        WRITE !!,"This report will produce a list of patients who have had allergies entered"

 +7        WRITE !,"onto their problem list in a specified date range.  If you are using"

 +8        WRITE !,"this list to populate the Allergy Tracking module you should"

 +9        WRITE !,"first run the Option 'List all patients with Allergies on their"

 +10       WRITE !,"problem list'.  You would use that report to enter the allergies"

 +11       WRITE !,"into the Allergy tracking module.  When you have finished that list"

 +12       WRITE !,"you can use this list to pick up any allergies entered onto the problem"

 +13       WRITE !,"list after you have ran and processed that list.",!

 +14       WRITE !

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !,"Please enter the date range for which allergies have been entered",!,"onto the problem list.",!

 +2        WRITE !

           SET DIR(0)="D^:DT:EP"

           SET DIR("A")="Enter beginning Date"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET APCDBD=Y

ED        ;get ending date

 +1        WRITE !

           SET DIR(0)="DA^"_APCDBD_":DT:EP"

           SET DIR("A")="Enter ending Date:  "

           SET Y=APCDBD

           DO DD^%DT

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET APCDED=Y

 +4        SET X1=APCDBD

           SET X2=-1

           DO C^%DTC

           SET APCDSD=X

           SET Y=APCDBD

           DO DD^%DT

           SET APCDBDD=Y

           SET Y=APCDED

           DO DD^%DT

           SET APCDEDD=Y

 +5       ;

ZIS       ;

 +1        SET XBRC="PROC^APCDALGQ"

           SET XBRP="PRINT^APCDALGQ"

           SET XBNS="APCD"

           SET XBRX="XIT^APCDALGQ"

 +2        DO ^XBDBQUE

XIT       ;

 +1        DO EN^XBVK("APCD")

 +2        DO ^XBFMK

 +3        QUIT 

XTMP(N,T) ;EP

 +1        IF $GET(N)=""

               QUIT 

 +2        SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T

 +3        QUIT 

 +4       ;

PROC      ;EP - entry point for processing

 +1        SET APCDJOB=$JOB

           SET APCDBTH=$HOROLOG

           SET APCDTOT=0

           SET APCDBT=$HOROLOG

 +2        DO XTMP("APCDALGQ","PCC PROBLEM LIST ALLERGY LIST")

 +3        SET APCDET=$HOROLOG

 +4        SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT 

               DO PROC1

 +5        QUIT 

PROC1     ;

 +1       ;no deceased patients

           IF $$DOD^AUPNPAT(DFN)]""

               QUIT 

 +2       ;no inactive patients

           IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)="I"

               QUIT 

 +3       ;Q:'$$LASTVD(DFN,APCDBD,APCDED)  ;no visit in time perio

 +4        SET APCDX=0

           FOR 

               SET APCDX=$ORDER(^AUPNPROB("AC",DFN,APCDX))

               IF APCDX'=+APCDX

                   QUIT 

               SET G=0

               Begin DoDot:1

 +5                IF $PIECE(^AUPNPROB(APCDX,0),U,8)<APCDBD

                       QUIT 

 +6                IF $PIECE(^AUPNPROB(APCDX,0),U,8)>APCDED

                       QUIT 

 +7       ;deleted

                   IF $PIECE(^AUPNPROB(APCDX,0),U,12)="D"

                       QUIT 

 +8                SET APCDP=$PIECE($GET(^AUPNPROB(APCDX,0)),U)

 +9                IF APCDP=""

                       QUIT 

 +10               SET APCDICD=$PIECE($$ICDDX^ICDEX(APCDP),U,2)

 +11               IF APCDICD=""

                       QUIT 

 +12      ;IHS/CMI/LAB - no narr

                   IF $PIECE(^AUPNPROB(APCDX,0),U,5)=""

                       QUIT 

 +13               SET APCDSNKA=0

 +14               IF APCDICD="692.3"

                       SET G=1

                       QUIT 

 +15               IF APCDICD="693.0"

                       SET G=1

                       QUIT 

 +16               IF APCDICD="995.0"

                       SET G=1

                       QUIT 

 +17               IF APCDICD=995.2

                       SET G=1

                       QUIT 

 +18               IF (+APCDICD'<999.4)

                       IF (+APCDICD'>999.8)

                           SET G=1

                           QUIT 

 +19               IF APCDICD?1"V14."1E

                       SET G=1

                       QUIT 

 +20               IF APCDICD="692.5"

                       SET G=1

                       QUIT 

 +21               IF APCDICD="693.1"

                       SET G=1

                       QUIT 

 +22               IF APCDICD["V15.0"

                       SET G=1

                       QUIT 

 +23               IF $EXTRACT(APCDICD,1,3)=692

                       IF APCDICD'="692.9"

                           SET G=1

                           QUIT 

 +24               IF APCDICD="693.8"

                       SET G=1

                       QUIT 

 +25               IF APCDICD="693.9"

                       SET G=1

                       QUIT 

 +26               IF APCDICD="989.5"

                       SET G=1

                       QUIT 

 +27               IF APCDICD="995.3"

                       SET G=1

                       QUIT 

 +28               IF APCDICD="995.2"

                       SET G=1

                       QUIT 

 +29      ;S N=$P(^AUTNPOV($P(^AUPNPROB(APCDX,0),U,5),0),U) I APCDICD="799.9"!(APCDICD="V82.9"),N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG") S APCDSNKA=1 S G=1 Q

 +30               SET N=$PIECE(^AUTNPOV($PIECE(^AUPNPROB(APCDX,0),U,5),0),U)

                   IF N["NO KNOWN ALLERG"!(N["NKA")!(N["NKDA")!(N["NO KNOWN DRUG ALLERG")

                       SET APCDSNKA=1

                       SET G=1

                       QUIT 

               End DoDot:1

               IF G

                   SET ^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN,APCDX)=""

 +31       QUIT 

LASTVD(P,BDATE,EDATE) ;

 +1        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT ""

 +2        KILL ^TMP($JOB,"A")

 +3        SET A="^TMP($J,""A"","

           SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)

           SET E=$$START1^APCLDF(B,A)

 +4        IF '$DATA(^TMP($JOB,"A",1))

               QUIT ""

 +5        SET (X,G)=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"A",X))

               IF X'=+X!(G)

                   QUIT 

               SET V=$PIECE(^TMP($JOB,"A",X),U,5)

               Begin DoDot:1

 +6                IF '$DATA(^AUPNVSIT(V,0))

                       QUIT 

 +7                IF '$PIECE(^AUPNVSIT(V,0),U,9)

                       QUIT 

 +8                IF $PIECE(^AUPNVSIT(V,0),U,11)

                       QUIT 

 +9                IF '$DATA(^AUPNVPRV("AD",V))

                       QUIT 

 +10               IF "SAHOIRCT"'[$PIECE(^AUPNVSIT(V,0),U,7)

                       QUIT 

 +11               IF "V"[$PIECE(^AUPNVSIT(V,0),U,3)

                       QUIT 

 +12               SET G=1

 +13               QUIT 

               End DoDot:1

 +14       QUIT G

PRINT     ;

 +1        SET APCD80D="-------------------------------------------------------------------------------"

 +2        SET Y=APCDBD

           DO DD^%DT

           SET APCDBDD=Y

           SET Y=APCDED

           DO DD^%DT

           SET APCDEDD=Y

 +3        SET APCDPG=0

 +4        IF '$DATA(^XTMP("APCDALGQ",APCDJOB,APCDBTH))

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +5        DO HEAD

 +6        SET DFN=0

           FOR 

               SET DFN=$ORDER(^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN))

               IF DFN'=+DFN!($DATA(APCDQ))

                   QUIT 

               Begin DoDot:1

 +7                IF $Y>(IOSL-6)

                       DO HEAD

                       IF $DATA(APCDQ)

                           QUIT 

 +8                WRITE !!,$PIECE(^DPT(DFN,0),U),?31,$$HRN^AUPNPAT(DFN,DUZ(2)),?42,$$DOB^AUPNPAT(DFN,"E")

 +9                WRITE !?3,"DATE ADDED",?17,"DX",?24,"PROVIDER NARRATIVE"

 +10               WRITE !?3,"----------",?17,"--",?24,"------------------"

 +11               SET APCDP=0

                   FOR 

                       SET APCDP=$ORDER(^XTMP("APCDALGQ",APCDJOB,APCDBTH,DFN,APCDP))

                       IF APCDP=""!($DATA(APCDQ))

                           QUIT 

                       Begin DoDot:2

 +12                       WRITE !?3,$$VAL^XBDIQ1(9000011,APCDP,.08),?17,$$VAL^XBDIQ1(9000011,APCDP,.01),?24,$$VAL^XBDIQ1(9000011,APCDP,.05)

                       End DoDot:2

               End DoDot:1

DONE      ;

 +1        KILL ^XTMP("APCDALGQ",APCDJOB,APCDBTH),APCDJOB,APCDBTH

 +2        QUIT 

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

HEAD       IF 'APCDPG

               GOTO HEAD1

 +1        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET APCDQ=""

                       QUIT 

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

           SET APCDPG=APCDPG+1

 +2        WRITE $PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",APCDPG,!

 +3        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +4        SET X="PATIENTS WITH ALLERGIES OR DOCUMENTED NO KNOWN ALLERGIES ON PCC PROBLEM LIST"

           WRITE $$CTR(X),!

 +5        SET X="ALLERGIES ADDED TO THE PROBLEM:  "_APCDBDD_"  TO  "_APCDEDD

           WRITE $$CTR(X),!

 +6        WRITE "PATIENT NAME",?31,"CHART #",?45,"DOB",!,APCD80D

 +7        QUIT