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
