Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCDALGP

APCDALGP.m

Go to the documentation of this file. 
  1. APCDALGP ; IHS/CMI/LAB - PRINT ALLERGY LIST FROM PROBLEM LIST ;
  1.  ;;2.0;IHS PCC SUITE;**5,11**;MAY 14, 2009;Build 58
  1.  ;
  1. START ;
  1.  D XIT
  1.  I '$D(IOF) D HOME^%ZIS
  1.  W @(IOF),!!
  1.  W "*******  LIST OF PATIENTS WITH ALLERGIES ON PROBLEM LIST  *******",!
  1.  W "This report will produce a list of patients who have an allergy or NKA",!
  1.  W "entered on the PCC Problem List.",!,"The pharmacy staff can use this list to add these allergies "
  1.  W !,"into the Allergy Tracking module.  When you have finished processing this list"
  1.  W !,"you can then run the Option 'List Patients w/Allergies entered in a Date Range'"
  1.  W !,"to pick up any allergies entered onto the Problem list after you"
  1.  W !,"ran this report.  Deceased patients and patients with inactive charts"
  1.  W !,"are not included on this list."
  1.  W !!,"This list can be very long at sites with many patients and whose"
  1.  W !,"providers have been maintaining up to date problem lists."
  1.  W !,"In order to make the list more manageable at those sites you will be"
  1.  W !,"prompted to enter the beginning and ending first character of "
  1.  W !,"the last name the patient.  You can then print all patients whose last"
  1.  W !,"name begins with A through C the first time and D through H the second, etc."
  1.  W !,"If you want all patients then when prompted to do so enter A and Z as the"
  1.  W !,"beginning and ending characters.",!!
  1. GETDATES ;
  1.  S APCDBC=""
  1.  S DIR(0)="F^1:1",DIR("A")="Start with last names beginning with" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D XIT Q
  1.  S APCDBC=Y
  1.  S APCDEC=""
  1.  S DIR(0)="F^1:1",DIR("A")="End with last names beginning with" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) D XIT Q
  1.  S APCDEC=Y
  1.  ;
  1. ZIS ;
  1.  S XBRC="PROC^APCDALGP",XBRP="PRINT^APCDALGP",XBNS="APCD",XBRX="XIT^APCDALGP"
  1.  D ^XBDBQUE
  1. XIT ;
  1.  D EN^XBVK("APCD")
  1.  D ^XBFMK
  1.  Q
  1. XTMP(N,T) ;EP
  1.  I $G(N)="" Q
  1.  S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_U_DT_U_T
  1.  Q
  1.  ;
  1. PROC ;EP - entry point for processing
  1.  S APCDJOB=$J,APCDBTH=$H,APCDTOT=0,APCDBT=$H
  1.  D XTMP("APCDALGP","PCC PROBLEM LIST ALLERGY LIST")
  1.  S APCDET=$H
  1.  S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D PROC1
  1.  Q
  1. PROC1 ;
  1.  Q:$$DOD^AUPNPAT(DFN)]""  ;no deceased patients
  1.  I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,5)="I" Q  ;no inactive patients
  1.  ;Q:'$$LASTVD(DFN,APCDBD,APCDED)  ;no visit in time perio
  1.  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)=""
  1.  .S C=$E($G(^DPT(DFN,0)))
  1.  .I APCDBC]C Q
  1.  .I C]APCDEC Q
  1.  .S APCDP=$P($G(^AUPNPROB(APCDX,0)),U)
  1.  .Q:APCDP=""
  1.  .S APCDICD=$P($$ICDDX^ICDEX(APCDP),U,2)
  1.  .Q:APCDICD=""
  1.  .I $P(^AUPNPROB(APCDX,0),U,5)="" Q  ;IHS/CMI/LAB - no narr
  1.  .I $P($G(^AUPNPROB(APCDX,2)),U,3)="E" Q  ;entered in error
  1.  .I $P(^AUPNPROB(APCDX,0),U,12)="D" Q  ;deleted
  1.  .S APCDSNKA=0
  1.  .I APCDICD="692.3" S G=1 Q
  1.  .I APCDICD="693.0" S G=1 Q
  1.  .I APCDICD="995.0" S G=1 Q
  1.  .I APCDICD=995.2 S G=1 Q
  1.  .I (+APCDICD'<999.4),(+APCDICD'>999.8) S G=1 Q
  1.  .I APCDICD?1"V14."1E S G=1 Q
  1.  .I APCDICD="692.5" S G=1 Q
  1.  .I APCDICD="693.1" S G=1 Q
  1.  .I APCDICD["V15.0" S G=1 Q
  1.  .I $E(APCDICD,1,3)=692,APCDICD'="692.9" S G=1 Q
  1.  .I APCDICD="693.8" S G=1 Q
  1.  .I APCDICD="693.9" S G=1 Q
  1.  .I APCDICD="989.5" S G=1 Q
  1.  .I APCDICD="995.3" S G=1 Q
  1.  .I APCDICD="995.2" S G=1 Q
  1.  .;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
  1.  .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
  1.  Q
  1. LASTVD(P,BDATE,EDATE) ;
  1.  I '$D(^AUPNVSIT("AC",P)) Q ""
  1.  K ^TMP($J,"A")
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  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
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:"SAHOIRCT"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .S G=1
  1.  .Q
  1.  Q G
  1. PRINT ;
  1.  S APCD80D="-------------------------------------------------------------------------------"
  1.  ;S Y=APCDBD D DD^%DT S APCDBDD=Y S Y=APCDED D DD^%DT S APCDEDD=Y
  1.  S APCDPG=0
  1.  I '$D(^XTMP("APCDALGP",APCDJOB,APCDBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE
  1.  D HEAD
  1.  S DFN=0 F  S DFN=$O(^XTMP("APCDALGP",APCDJOB,APCDBTH,DFN)) Q:DFN'=+DFN!($D(APCDQ))  D
  1.  .I $Y>(IOSL-6) D HEAD Q:$D(APCDQ)
  1.  .W !!,$P(^DPT(DFN,0),U),?31,$$HRN^AUPNPAT(DFN,DUZ(2)),?42,$$DOB^AUPNPAT(DFN,"E")
  1.  .W !?3,"DATE ADDED",?17,"DX",?24,"PROVIDER NARRATIVE"
  1.  .W !?3,"----------",?17,"--",?24,"------------------"
  1.  .S APCDP=0 F  S APCDP=$O(^XTMP("APCDALGP",APCDJOB,APCDBTH,DFN,APCDP)) Q:APCDP=""!($D(APCDQ))  D
  1.  ..W !?3,$$VAL^XBDIQ1(9000011,APCDP,.08),?17,$$VAL^XBDIQ1(9000011,APCDP,.01),?24,$$VAL^XBDIQ1(9000011,APCDP,.05)
  1. DONE ;
  1.  K ^XTMP("APCDALGP",APCDJOB,APCDBTH),APCDJOB,APCDBTH
  1.  Q
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.          ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.          ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  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
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S APCDPG=APCDPG+1
  1.  W $P(^VA(200,DUZ,0),U,2),?72,"Page ",APCDPG,!
  1.  W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!
  1.  S X="PATIENTS WITH ALLERGIES OR DOCUMENTED NO KNOWN ALLERGIES ON PCC PROBLEM LIST" W $$CTR(X),!
  1.  S X="PATIENTS WITH LAST NAMES BEGINNING WITH "_APCDBC_" through "_APCDEC W $$CTR(X),!
  1.  W "PATIENT NAME",?31,"CHART #",?45,"DOB",!,APCD80D
  1.  Q