APCDALGP ; 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 ON PROBLEM LIST *******",!
W "This report will produce a list of patients who have an allergy or NKA",!
W "entered on the PCC Problem List.",!,"The pharmacy staff can use this list to add these allergies "
W !,"into the Allergy Tracking module. When you have finished processing this list"
W !,"you can then run the Option 'List Patients w/Allergies entered in a Date Range'"
W !,"to pick up any allergies entered onto the Problem list after you"
W !,"ran this report. Deceased patients and patients with inactive charts"
W !,"are not included on this list."
W !!,"This list can be very long at sites with many patients and whose"
W !,"providers have been maintaining up to date problem lists."
W !,"In order to make the list more manageable at those sites you will be"
W !,"prompted to enter the beginning and ending first character of "
W !,"the last name the patient. You can then print all patients whose last"
W !,"name begins with A through C the first time and D through H the second, etc."
W !,"If you want all patients then when prompted to do so enter A and Z as the"
W !,"beginning and ending characters.",!!
GETDATES ;
S APCDBC=""
S DIR(0)="F^1:1",DIR("A")="Start with last names beginning with" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D XIT Q
S APCDBC=Y
S APCDEC=""
S DIR(0)="F^1:1",DIR("A")="End with last names beginning with" KILL DA D ^DIR KILL DIR
I $D(DIRUT) D XIT Q
S APCDEC=Y
;
ZIS ;
S XBRC="PROC^APCDALGP",XBRP="PRINT^APCDALGP",XBNS="APCD",XBRX="XIT^APCDALGP"
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("APCDALGP","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("APCDALGP",APCDJOB,APCDBTH,DFN,APCDX)=""
.S C=$E($G(^DPT(DFN,0)))
.I APCDBC]C Q
.I C]APCDEC Q
.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
.I $P($G(^AUPNPROB(APCDX,2)),U,3)="E" Q ;entered in error
.I $P(^AUPNPROB(APCDX,0),U,12)="D" Q ;deleted
.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("APCDALGP",APCDJOB,APCDBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE
D HEAD
S DFN=0 F S DFN=$O(^XTMP("APCDALGP",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("APCDALGP",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("APCDALGP",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="PATIENTS WITH LAST NAMES BEGINNING WITH "_APCDBC_" through "_APCDEC W $$CTR(X),!
W "PATIENT NAME",?31,"CHART #",?45,"DOB",!,APCD80D
Q
APCDALGP ; 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 ON PROBLEM LIST *******",!
+5 WRITE "This report will produce a list of patients who have an allergy or NKA",!
+6 WRITE "entered on the PCC Problem List.",!,"The pharmacy staff can use this list to add these allergies "
+7 WRITE !,"into the Allergy Tracking module. When you have finished processing this list"
+8 WRITE !,"you can then run the Option 'List Patients w/Allergies entered in a Date Range'"
+9 WRITE !,"to pick up any allergies entered onto the Problem list after you"
+10 WRITE !,"ran this report. Deceased patients and patients with inactive charts"
+11 WRITE !,"are not included on this list."
+12 WRITE !!,"This list can be very long at sites with many patients and whose"
+13 WRITE !,"providers have been maintaining up to date problem lists."
+14 WRITE !,"In order to make the list more manageable at those sites you will be"
+15 WRITE !,"prompted to enter the beginning and ending first character of "
+16 WRITE !,"the last name the patient. You can then print all patients whose last"
+17 WRITE !,"name begins with A through C the first time and D through H the second, etc."
+18 WRITE !,"If you want all patients then when prompted to do so enter A and Z as the"
+19 WRITE !,"beginning and ending characters.",!!
GETDATES ;
+1 SET APCDBC=""
+2 SET DIR(0)="F^1:1"
SET DIR("A")="Start with last names beginning with"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
DO XIT
QUIT
+4 SET APCDBC=Y
+5 SET APCDEC=""
+6 SET DIR(0)="F^1:1"
SET DIR("A")="End with last names beginning with"
KILL DA
DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
DO XIT
QUIT
+8 SET APCDEC=Y
+9 ;
ZIS ;
+1 SET XBRC="PROC^APCDALGP"
SET XBRP="PRINT^APCDALGP"
SET XBNS="APCD"
SET XBRX="XIT^APCDALGP"
+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("APCDALGP","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 SET C=$EXTRACT($GET(^DPT(DFN,0)))
+6 IF APCDBC]C
QUIT
+7 IF C]APCDEC
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 ;entered in error
IF $PIECE($GET(^AUPNPROB(APCDX,2)),U,3)="E"
QUIT
+14 ;deleted
IF $PIECE(^AUPNPROB(APCDX,0),U,12)="D"
QUIT
+15 SET APCDSNKA=0
+16 IF APCDICD="692.3"
SET G=1
QUIT
+17 IF APCDICD="693.0"
SET G=1
QUIT
+18 IF APCDICD="995.0"
SET G=1
QUIT
+19 IF APCDICD=995.2
SET G=1
QUIT
+20 IF (+APCDICD'<999.4)
IF (+APCDICD'>999.8)
SET G=1
QUIT
+21 IF APCDICD?1"V14."1E
SET G=1
QUIT
+22 IF APCDICD="692.5"
SET G=1
QUIT
+23 IF APCDICD="693.1"
SET G=1
QUIT
+24 IF APCDICD["V15.0"
SET G=1
QUIT
+25 IF $EXTRACT(APCDICD,1,3)=692
IF APCDICD'="692.9"
SET G=1
QUIT
+26 IF APCDICD="693.8"
SET G=1
QUIT
+27 IF APCDICD="693.9"
SET G=1
QUIT
+28 IF APCDICD="989.5"
SET G=1
QUIT
+29 IF APCDICD="995.3"
SET G=1
QUIT
+30 IF APCDICD="995.2"
SET G=1
QUIT
+31 ;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
+32 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("APCDALGP",APCDJOB,APCDBTH,DFN,APCDX)=""
+33 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 ;S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y
+3 SET APCDPG=0
+4 IF '$DATA(^XTMP("APCDALGP",APCDJOB,APCDBTH))
DO HEAD
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 DO HEAD
+6 SET DFN=0
FOR
SET DFN=$ORDER(^XTMP("APCDALGP",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("APCDALGP",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("APCDALGP",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="PATIENTS WITH LAST NAMES BEGINNING WITH "_APCDBC_" through "_APCDEC
WRITE $$CTR(X),!
+6 WRITE "PATIENT NAME",?31,"CHART #",?45,"DOB",!,APCD80D
+7 QUIT
