APCLVL01 ; IHS/CMI/LAB - SCREEN LOGIC ;
;;2.0;IHS PCC SUITE;**20**;MAY 14, 2009;Build 25
;
INFORM ;EP
S APCLTCW=0
W:$D(IOF) @IOF
S APCLLHDR="PCC "_$S(APCLPTVS="V":"VISIT",1:"PATIENT")_" GENERAL RETRIEVAL"
W ?((80-$L(APCLLHDR))/2),APCLLHDR
W !,"This report will list or count "_$S(APCLPTVS="V":"visits",1:"patients")_" based on selection criteria"
W !,"entered by the user. You will be asked, in three separate steps, to identify"
W !,"your selection criteria, what you wish displayed for each "_$S(APCLPTVS="V":"visit",1:"patient")_", and the ",!,"sorting order for your list. You may save the logic used to produce the report "
W !,"for future use. If you design a report that is 80 characters or less in width,",!,"it can be displayed on your screen or printed. If your report is 81-132"
W !,"characters wide, it must be printed - and only on a printer capable of ",!,"producing 132 character lines. You may limit the "_$S(APCLPTVS="V":"visits",1:"patients")_" in your report to",!,"pre-established Search"
W " Templates you have created in QMan, Case Management, or",!,"other RPMS tools. If your"
W " template was created in Case Management or in QMan,",!,"using Patients as the Search Subject, this is a Search Template of Patients.",!
G:APCLPTVS="P" INFORMQ
W "If your template was created in QMan using Visits as the Search Subject, this is",!,"a Search Template of Visits."
W !,"Select one of the following and then proceed to the Date Range and"
W !,"Selection Criteria screens:"
INFORMQ Q
ADD ;EP
K APCLCAND
W !!
I $D(APCLNCAN) G ADD1
I $D(APCLSEAT),'$D(APCLEP1) G ADD1
S DIR(0)="Y",DIR("A")="Do you want to use a PREVIOUSLY DEFINED REPORT",DIR("B")="N" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) S APCLQUIT=1 Q
I 'Y G ADD1
S DIC="^APCLVRPT(",DIC("S")="I $P(^(0),U,2)&($P(^(0),U,6)=APCLPTVS)" S:$D(APCLEP1) DIC("S")=DIC("S")_"&($P(^(0),U,9)=APCLPACK)" S DIC(0)="AEQ",DIC("A")="REPORT NAME: ",D="C" D IX^DIC K DIC,DA,DR
I Y=-1 S APCLQUIT=1 Q
S APCLRPT=+Y,APCLCAND=1
;--- set up sorting and report control variables
S APCLSORT=$P(^APCLVRPT(APCLRPT,0),U,7),APCLSORV=$P(^(0),U,8),APCLSPAG=$P(^(0),U,4),APCLCTYP=$P(^(0),U,5),$P(^APCLVRPT(APCLRPT,13),U)=$G(APCLBD),$P(^APCLVRPT(APCLRPT,13),U,2)=$G(APCLED)
S X=0 F S X=$O(^APCLVRPT(APCLRPT,12,X)) Q:X'=+X S APCLTCW=APCLTCW+$P(^APCLVRPT(APCLRPT,12,X,0),U,2)+2
Q
ADD1 ;
;CREATE REPORT ENTRY IN FILEMAN FILE
S %H=$H D YX^%DTC S X=$P(^VA(200,DUZ,0),U)_"-"_Y,DIC(0)="L",DIC="^APCLVRPT(",DLAYGO=9001003.8,DIADD=1,DIC("DR")=".13////"_DUZ D ^DIC K DIC,DA,DR,DIADD,DLAYGO I Y=-1 W !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!" S APCLQUIT=1 Q
S APCLRPT=+Y
K DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
;DELETE ALL 11 MULTIPLE HERE
K ^APCLVRPT(APCLRPT,11)
Q
PAUSE ;EP
Q:$E(IOST)'="C"!(IO'=IO(0))
W ! S DIR(0)="EO",DIR("A")="Press enter to continue...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q
;
N ;EP
K ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
S DIR(0)="FO^1:20",DIR("A")=$S($G(^APCLVSTS(APCLCRIT,28))]"":^APCLVSTS(APCLCRIT,28),1:"Enter a Range of numbers (e.g. 5-12,1-1)"),DIR("?")=$S($G(^APCLVSTS(APCLCRIT,27))]"":^APCLVSTS(APCLCRIT,27),1:"Enter a range of number (e.g. 5-12, 1-1)")
D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !!,"No numeric range entered. All numerics will be included." Q
I $D(^APCLVSTS(APCLCRIT,25)) S X=Y X ^(25) I '$D(X),$D(^APCLVSTS(APCLCRIT,26)) W !! X ^(26) G N ;if input tx exists and fails G N
I '$D(^APCLVSTS(APCLCRIT,25)),Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter a numeric range in the format nnn-nnn. E.g. 0-5, 0-99, 5-20." G N
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1" S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=$P(Y,"-"),^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$P(Y,"-"),1)=""
S $P(^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0),U,2)=$P(Y,"-",2)
Q
J ;EP - JUST A HIT
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",1,1)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_1_"^"_1
Q
Y ;EP - called from apclvl0
S DIR(0)="S^1:"_APCLTEXT_";0:"_$S(APCLTEXT="Homeless":"NOT ",1:"NO ")_APCLTEXT_"",DIR("A")="Should "_$S(APCLPTVS="P":"patient",1:"visit")_" have",DIR("B")="1" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=Y,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Y,1)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_1_"^"_1
Q
C ;EP
W !!,"Enter a string which will be searched for in the narrative text.",!,"The system will check for any narrative that contains this string.",!
K ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
S DIR(0)="FO^1:40",DIR("A")="Enter a String of Characters for Search (e.g. DIABETES) " D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !!,"No range entered. All ",APCLTEXT," will be included." Q
;I $D(^APCLVSTS(APCLCRIT,21)) S X=Y X ^(21) I '$D(X),$D(^APCLVSTS(APCLCRIT,22)) W !! X ^(22) G F ;if input tx exists and fails G N
;I '$D(^APCLVSTS(APCLCRIT,21)),Y'?1.ANP1":"1.ANP W !!,$C(7),$C(7),"Enter an free text range in the format AAA:AAA. E.g. 94-01:94-200,CA:CZ, A:Z." G F
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=0,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1" S APCLCNT=APCLCNT+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=X,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,APCLCNT)=""
Q
S ;EP
;special logic for hard coded lookups
X ^APCLVSTS(APCLCRIT,5)
Q
LABLOINC ;EP
;prompt for lab tests, loinc codes, taxonomy on each
W !,"This selection item allows you to search for visits on which selected"
W !,"lab test were done. You can search by selected lab test names, a taxonomy"
W !,"of lab test names, by selected loinc codes, by a taxonomy of LOINC codes,"
W !,"or by any combination of the above."
K APCLLABT
LABL ;
I $D(APCLLABT) D LABLIST
W !,"Please select which of the items below you want to use to search"
W !,"for lab tests:"
S DIR(0)="SO^1:Lab Test Name;2:Lab Test Taxonomy;3:LOINC Code;4:LOINC Code Taxonomy",DIR("A")="Select" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
I Y="" Q
S APCLCH=Y
I APCLCH=1 D LABL1
I APCLCH=2 D LABL2
I APCLCH=3 D LABL3
I APCLCH=4 D LABL4
G LABL
LABL1 ;
W !,"Please enter an '^' when you are finished selecting lab tests"
K DIR S DIR(0)="9000010.09,.01",DIR("A")="Enter Lab Test Name" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S APCLLABT("LAB",+Y)=""
G LABL1
LABL2 ;
K DIC,DLAYGO,DIADD S DIC="^ATXLAB(",DIC(0)="AEMQ" D ^DIC K DIC
I Y=-1 Q
S X=0 F S X=$O(^ATXLAB(+Y,21,X)) Q:X'=+X S Z=$P(^ATXLAB(+Y,21,X,0),U),APCLLABT("LAB",Z)=""
G LABL2
LABL3 ;
W !,"Please enter an '^' when you are finished selecting lab tests"
K DIR S DIR(0)="9000010.09,1113",DIR("A")="Enter LOINC Code" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S Z=$P(^LAB(95.3,+Y,0),U)_$P(^LAB(95.3,+Y,0),U,15)
S APCLLABT("LOINC",Z)=""
G LABL3
LABL4 ;
K DIC,DLAYGO,DIADD S DIC="^ATXAX(",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,15)=95.3" D ^DIC K DIC
I Y=-1 Q
S X=0 F S X=$O(^ATXAX(+Y,21,X)) Q:X'=+X S Z=$P(^ATXAX(+Y,21,X,0),U),APCLLABT("LOINC",Z)=""
G LABL4
LABLIST ;
W !!,"So far you have selected the following lab tests and/or LOINC Codes:"
S X="",C=0 F S X=$O(APCLLABT("LAB",X)) Q:X'=+X D
.I C=3 S C=1 I 1
.E S C=C+1
.I C=1 W !
.W ?$S(C=1:1,C=2:27,C=3:53),$E($P(^LAB(60,X,0),U),1,25)
.Q
S X="",C=0 F S X=$O(APCLLABT("LOINC",X)) Q:X="" D
.I C=3 S C=1 I 1
.E S C=C+1
.I C=1 W !
.W ?$S(C=1:1,C=2:27,C=3:53),X
.Q
Q:'$D(APCLLABT)
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1" S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",1,1)=""
Q
;
GETREG ;EP
;get register name to use to exclude patients
K APCLEXRG
S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register containing the patients to exclude: " D ^DIC K DIC
I Y=-1 Q
S APCLEXRG=+Y
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1" S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=+Y,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",+Y,1)=""
Q
;
FAMHXR ;EP - family history with relation
;get diagnosis and relation and store as 2 pieces
;with a dash in between
K AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN"),^UTILITY("AMQQ TAX",$J)
K DIC,X,Y,DD S X="FAMILY HISTORY DIAGNOSIS",DIC="^AMQQ(5,",DIC(0)="EQXM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA,DINUM,DICR I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" Q
S APCLQMAN=+Y
D PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
I '$D(^XTMP("APCLVL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^APCLVSTS(APCLCRIT,0),U)," selected, all will be included." D PAUSE
I $D(^XTMP("APCLVL",$J,"QMAN","*")) K ^XTMP("APCLVL",$J,"QMAN") W !!,"All diagnosis will be included." D PAUSE
;now get relation
K DIC
K APCLREL D GETREL
I '$O(APCLREL(0)) W !!,"No relationships selected, ANY non-null relationship will be included." D PAUSE
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
I '$D(^XTMP("APCLVL",$J,"QMAN")) D G Q1
.S X=""
.I '$D(APCLREL) S Z="",Y=Y+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y Q
.S Z=0 F S Z=$O(APCLREL(Z)) Q:Z'=+Z D
..S Y=Y+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
;
S X="",Y=0 F S X=$O(^XTMP("APCLVL",$J,"QMAN",X)) Q:X="" D
.I '$D(APCLREL) S Z="",Y=Y+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y Q
.S Z=0 F S Z=$O(APCLREL(Z)) Q:Z'=+Z D
..S Y=Y+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
Q1 K X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN")
K APCLREL,DIR
Q
GETREL ;
K DIR
S DIR(0)="9000014.1,.01O",DIR("A")="ENTER PCC RELATIONSHIP" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=-1
I Y="" Q
S APCLREL(+Y)=""
G GETREL
Q
APPTS ;EP - Appointments
;get date range as pieces 1 and 2 and clinics as pieces 3-99 or 3rd piece blank if any clinic
;beginning and ending date
NEW APCLBDAT,APCLEDAT,APCLSDAT,APCLCLN,APCLT
APPTBD ;get beginning date
W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning Appointment date for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
S APCLBDAT=Y
APPTED ;get ending date
W ! S DIR(0)="D^"_APCLBDAT_"::EP",DIR("A")="Enter ending Appointment date for Search" S Y=APCLBDAT D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G APPTBD
S APCLEDAT=Y
S X1=APCLBDAT,X2=-1 D C^%DTC S APCLSDAT=X_".9999"
;get clinics
APPCLNS ;
K APCLCLN
S APCLT=""
S DIR(0)="S^A:ANY Clinic (All Clinics);S:Selected Set of Clinics",DIR("A")="Which Appointment Clinics should be included",DIR("B")="S" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No Clinics chosen....item will not be used as a selection item..." D PAUSE Q
I Y="A" G SETAPPT
;
K APCLCLN
APPCLNS1 ;
S DIR(0)="9001003.7,999916",DIR("A")="Enter APPOINTMENT CLINIC" KILL DA D ^DIR KILL DIR
I $D(DIRUT),'$O(APCLCLN(0)) W !!,"No clinics chosen...." G APPCLNS
I Y="",'$O(APCLCLN(0)) W !!,"No clinics chosen...." G APPCLNS
I Y S APCLCLN(+Y)="" G APPCLNS1
SETAPPT ;
K APCLCLN
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=0,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT
S C=2,X=0 F S X=$O(APCLCLN(X)) Q:X'=+X S C=C+1,$P(^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0),U,C)=X
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
Q
PLDOO ;EP - Appointments
;get date range as pieces 1 and 2 and clinics as pieces 3-99 or 3rd piece blank if any clinic
;beginning and ending date
NEW APCLBDAT,APCLEDAT,APCLSDAT,APCLCLN,APCLT
PLDOOBD ;get beginning date
W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning Date of Onset for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
S APCLBDAT=Y
PLDOOED ;get ending date
W ! S DIR(0)="D^"_APCLBDAT_"::EP",DIR("A")="Enter ending Date of Onset date for Search" S Y=APCLBDAT D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G PLDOOBD
S APCLEDAT=Y
S X1=APCLBDAT,X2=-1 D C^%DTC S APCLSDAT=X_".9999"
;get clinics
PLDXS ;
K APCLPDOO
S APCLT=""
S DIR(0)="S^A:ANY Diagnosis;S:Selected Set of Diagnoses",DIR("A")="Which Problem List Diagnoses should be included",DIR("B")="S" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !!,"No dx chosen....item will not be used as a selection item..." D PAUSE Q
I Y="A" G SETPLDOO
;
K APCLPDOO
PLDXS1 ;
K AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN"),^UTILITY("AMQQ TAX",$J)
K DIC,X,Y,DD S X="DIAGNOSIS",DIC="^AMQQ(5,",DIC(0)="EQXM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA,DINUM,DICR I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" Q
S APCLQMAN=+Y
D PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
I '$D(^XTMP("APCLVL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^APCLVSTS(APCLCRIT,0),U)," selected." G PLDXS
I $D(^XTMP("APCLVL",$J,"QMAN","*")) K ^XTMP("APCLVL",$J,"QMAN") W !!,"*** All items selected, if you want all then choose ANY diagnosis." G PLDXS
S X="",Y=0 F S X=$O(^XTMP("APCLVL",$J,"QMAN",X)) Q:X="" S APCLPDOO(X)=""
Q11 K X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN")
SETPLDOO ;
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=0,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT
S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
Q
APCLVL01 ; IHS/CMI/LAB - SCREEN LOGIC ;
+1 ;;2.0;IHS PCC SUITE;**20**;MAY 14, 2009;Build 25
+2 ;
INFORM ;EP
+1 SET APCLTCW=0
+2 IF $DATA(IOF)
WRITE @IOF
+3 SET APCLLHDR="PCC "_$SELECT(APCLPTVS="V":"VISIT",1:"PATIENT")_" GENERAL RETRIEVAL"
+4 WRITE ?((80-$LENGTH(APCLLHDR))/2),APCLLHDR
+5 WRITE !,"This report will list or count "_$SELECT(APCLPTVS="V":"visits",1:"patients")_" based on selection criteria"
+6 WRITE !,"entered by the user. You will be asked, in three separate steps, to identify"
+7 WRITE !,"your selection criteria, what you wish displayed for each "_$SELECT(APCLPTVS="V":"visit",1:"patient")_", and the ",!,"sorting order for your list. You may save the logic used to produce the report "
+8 WRITE !,"for future use. If you design a report that is 80 characters or less in width,",!,"it can be displayed on your screen or printed. If your report is 81-132"
+9 WRITE !,"characters wide, it must be printed - and only on a printer capable of ",!,"producing 132 character lines. You may limit the "_$SELECT(APCLPTVS="V":"visits",1:"patients")_" in your report to",!,"pre-established Search"
+10 WRITE " Templates you have created in QMan, Case Management, or",!,"other RPMS tools. If your"
+11 WRITE " template was created in Case Management or in QMan,",!,"using Patients as the Search Subject, this is a Search Template of Patients.",!
+12 IF APCLPTVS="P"
GOTO INFORMQ
+13 WRITE "If your template was created in QMan using Visits as the Search Subject, this is",!,"a Search Template of Visits."
+14 WRITE !,"Select one of the following and then proceed to the Date Range and"
+15 WRITE !,"Selection Criteria screens:"
INFORMQ QUIT
ADD ;EP
+1 KILL APCLCAND
+2 WRITE !!
+3 IF $DATA(APCLNCAN)
GOTO ADD1
+4 IF $DATA(APCLSEAT)
IF '$DATA(APCLEP1)
GOTO ADD1
+5 SET DIR(0)="Y"
SET DIR("A")="Do you want to use a PREVIOUSLY DEFINED REPORT"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+6 IF $DATA(DIRUT)
SET APCLQUIT=1
QUIT
+7 IF 'Y
GOTO ADD1
+8 SET DIC="^APCLVRPT("
SET DIC("S")="I $P(^(0),U,2)&($P(^(0),U,6)=APCLPTVS)"
IF $DATA(APCLEP1)
SET DIC("S")=DIC("S")_"&($P(^(0),U,9)=APCLPACK)"
SET DIC(0)="AEQ"
SET DIC("A")="REPORT NAME: "
SET D="C"
DO IX^DIC
KILL DIC,DA,DR
+9 IF Y=-1
SET APCLQUIT=1
QUIT
+10 SET APCLRPT=+Y
SET APCLCAND=1
+11 ;--- set up sorting and report control variables
+12 SET APCLSORT=$PIECE(^APCLVRPT(APCLRPT,0),U,7)
SET APCLSORV=$PIECE(^(0),U,8)
SET APCLSPAG=$PIECE(^(0),U,4)
SET APCLCTYP=$PIECE(^(0),U,5)
SET $PIECE(^APCLVRPT(APCLRPT,13),U)=$GET(APCLBD)
SET $PIECE(^APCLVRPT(APCLRPT,13),U,2)=$GET(APCLED)
+13 SET X=0
FOR
SET X=$ORDER(^APCLVRPT(APCLRPT,12,X))
IF X'=+X
QUIT
SET APCLTCW=APCLTCW+$PIECE(^APCLVRPT(APCLRPT,12,X,0),U,2)+2
+14 QUIT
ADD1 ;
+1 ;CREATE REPORT ENTRY IN FILEMAN FILE
+2 SET %H=$HOROLOG
DO YX^%DTC
SET X=$PIECE(^VA(200,DUZ,0),U)_"-"_Y
SET DIC(0)="L"
SET DIC="^APCLVRPT("
SET DLAYGO=9001003.8
SET DIADD=1
SET DIC("DR")=".13////"_DUZ
DO ^DIC
KILL DIC,DA,DR,DIADD,DLAYGO
IF Y=-1
WRITE !!,"UNABLE TO CREATE REPORT FILE ENTRY - NOTIFY SITE MANAGER!"
SET APCLQUIT=1
QUIT
+3 SET APCLRPT=+Y
+4 KILL DIC,DIADD,DLAYGO,DR,DA,DD,X,Y,DINUM
+5 ;DELETE ALL 11 MULTIPLE HERE
+6 KILL ^APCLVRPT(APCLRPT,11)
+7 QUIT
PAUSE ;EP
+1 IF $EXTRACT(IOST)'="C"!(IO'=IO(0))
QUIT
+2 WRITE !
SET DIR(0)="EO"
SET DIR("A")="Press enter to continue...."
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 QUIT
+4 ;
N ;EP
+1 KILL ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
+2 SET DIR(0)="FO^1:20"
SET DIR("A")=$SELECT($GET(^APCLVSTS(APCLCRIT,28))]"":^APCLVSTS(APCLCRIT,28),1:"Enter a Range of numbers (e.g. 5-12,1-1)")
SET DIR("?")=$SELECT($GET(^APCLVSTS(APCLCRIT,27))]"":^APCLVSTS(APCLCRIT,27),1:"Enter a range of number (e.g. 5-12, 1-1)")
+3 DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !!,"No numeric range entered. All numerics will be included."
QUIT
+5 ;if input tx exists and fails G N
IF $DATA(^APCLVSTS(APCLCRIT,25))
SET X=Y
XECUTE ^(25)
IF '$DATA(X)
IF $DATA(^APCLVSTS(APCLCRIT,26))
WRITE !!
XECUTE ^(26)
GOTO N
+6 IF '$DATA(^APCLVSTS(APCLCRIT,25))
IF Y'?1.3N1"-"1.3N
WRITE !!,$CHAR(7),$CHAR(7),"Enter a numeric range in the format nnn-nnn. E.g. 0-5, 0-99, 5-20."
GOTO N
+7 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+8 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1"
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=$PIECE(Y,"-")
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$PIECE(Y,"-"),1)=""
+9 SET $PIECE(^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0),U,2)=$PIECE(Y,"-",2)
+10 QUIT
J ;EP - JUST A HIT
+1 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+2 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",1,1)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_1_"^"_1
+3 QUIT
Y ;EP - called from apclvl0
+1 SET DIR(0)="S^1:"_APCLTEXT_";0:"_$SELECT(APCLTEXT="Homeless":"NOT ",1:"NO ")_APCLTEXT_""
SET DIR("A")="Should "_$SELECT(APCLPTVS="P":"patient",1:"visit")_" have"
SET DIR("B")="1"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 IF Y=""
QUIT
+4 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+5 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=Y
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",Y,1)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_1_"^"_1
+6 QUIT
C ;EP
+1 WRITE !!,"Enter a string which will be searched for in the narrative text.",!,"The system will check for any narrative that contains this string.",!
+2 KILL ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
+3 SET DIR(0)="FO^1:40"
SET DIR("A")="Enter a String of Characters for Search (e.g. DIABETES) "
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+4 IF Y=""
WRITE !!,"No range entered. All ",APCLTEXT," will be included."
QUIT
+5 ;I $D(^APCLVSTS(APCLCRIT,21)) S X=Y X ^(21) I '$D(X),$D(^APCLVSTS(APCLCRIT,22)) W !! X ^(22) G F ;if input tx exists and fails G N
+6 ;I '$D(^APCLVSTS(APCLCRIT,21)),Y'?1.ANP1":"1.ANP W !!,$C(7),$C(7),"Enter an free text range in the format AAA:AAA. E.g. 94-01:94-200,CA:CZ, A:Z." G F
+7 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+8 SET APCLCNT=0
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
SET APCLCNT=APCLCNT+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=X
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,APCLCNT)=""
+9 QUIT
S ;EP
+1 ;special logic for hard coded lookups
+2 XECUTE ^APCLVSTS(APCLCRIT,5)
+3 QUIT
LABLOINC ;EP
+1 ;prompt for lab tests, loinc codes, taxonomy on each
+2 WRITE !,"This selection item allows you to search for visits on which selected"
+3 WRITE !,"lab test were done. You can search by selected lab test names, a taxonomy"
+4 WRITE !,"of lab test names, by selected loinc codes, by a taxonomy of LOINC codes,"
+5 WRITE !,"or by any combination of the above."
+6 KILL APCLLABT
LABL ;
+1 IF $DATA(APCLLABT)
DO LABLIST
+2 WRITE !,"Please select which of the items below you want to use to search"
+3 WRITE !,"for lab tests:"
+4 SET DIR(0)="SO^1:Lab Test Name;2:Lab Test Taxonomy;3:LOINC Code;4:LOINC Code Taxonomy"
SET DIR("A")="Select"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 IF Y=""
QUIT
+7 SET APCLCH=Y
+8 IF APCLCH=1
DO LABL1
+9 IF APCLCH=2
DO LABL2
+10 IF APCLCH=3
DO LABL3
+11 IF APCLCH=4
DO LABL4
+12 GOTO LABL
LABL1 ;
+1 WRITE !,"Please enter an '^' when you are finished selecting lab tests"
+2 KILL DIR
SET DIR(0)="9000010.09,.01"
SET DIR("A")="Enter Lab Test Name"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET APCLLABT("LAB",+Y)=""
+5 GOTO LABL1
LABL2 ;
+1 KILL DIC,DLAYGO,DIADD
SET DIC="^ATXLAB("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
+2 IF Y=-1
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^ATXLAB(+Y,21,X))
IF X'=+X
QUIT
SET Z=$PIECE(^ATXLAB(+Y,21,X,0),U)
SET APCLLABT("LAB",Z)=""
+4 GOTO LABL2
LABL3 ;
+1 WRITE !,"Please enter an '^' when you are finished selecting lab tests"
+2 KILL DIR
SET DIR(0)="9000010.09,1113"
SET DIR("A")="Enter LOINC Code"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET Z=$PIECE(^LAB(95.3,+Y,0),U)_$PIECE(^LAB(95.3,+Y,0),U,15)
+5 SET APCLLABT("LOINC",Z)=""
+6 GOTO LABL3
LABL4 ;
+1 KILL DIC,DLAYGO,DIADD
SET DIC="^ATXAX("
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,15)=95.3"
DO ^DIC
KILL DIC
+2 IF Y=-1
QUIT
+3 SET X=0
FOR
SET X=$ORDER(^ATXAX(+Y,21,X))
IF X'=+X
QUIT
SET Z=$PIECE(^ATXAX(+Y,21,X,0),U)
SET APCLLABT("LOINC",Z)=""
+4 GOTO LABL4
LABLIST ;
+1 WRITE !!,"So far you have selected the following lab tests and/or LOINC Codes:"
+2 SET X=""
SET C=0
FOR
SET X=$ORDER(APCLLABT("LAB",X))
IF X'=+X
QUIT
Begin DoDot:1
+3 IF C=3
SET C=1
IF 1
+4 IF '$TEST
SET C=C+1
+5 IF C=1
WRITE !
+6 WRITE ?$SELECT(C=1:1,C=2:27,C=3:53),$EXTRACT($PIECE(^LAB(60,X,0),U),1,25)
+7 QUIT
End DoDot:1
+8 SET X=""
SET C=0
FOR
SET X=$ORDER(APCLLABT("LOINC",X))
IF X=""
QUIT
Begin DoDot:1
+9 IF C=3
SET C=1
IF 1
+10 IF '$TEST
SET C=C+1
+11 IF C=1
WRITE !
+12 WRITE ?$SELECT(C=1:1,C=2:27,C=3:53),X
+13 QUIT
End DoDot:1
+14 IF '$DATA(APCLLABT)
QUIT
+15 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+16 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1"
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",1,1)=""
+17 QUIT
+18 ;
GETREG ;EP
+1 ;get register name to use to exclude patients
+2 KILL APCLEXRG
+3 SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Register containing the patients to exclude: "
DO ^DIC
KILL DIC
+4 IF Y=-1
QUIT
+5 SET APCLEXRG=+Y
+6 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+7 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1"
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=+Y
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",+Y,1)=""
+8 QUIT
+9 ;
FAMHXR ;EP - family history with relation
+1 ;get diagnosis and relation and store as 2 pieces
+2 ;with a dash in between
+3 KILL AMQQTAXN
+4 KILL ^XTMP("APCLVL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB)
+5 KILL DIC,X,Y,DD
SET X="FAMILY HISTORY DIAGNOSIS"
SET DIC="^AMQQ(5,"
SET DIC(0)="EQXM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA,DINUM,DICR
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
QUIT
+6 SET APCLQMAN=+Y
+7 DO PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
+8 IF '$DATA(^XTMP("APCLVL",$JOB,"QMAN"))
WRITE !!,$CHAR(7),"** No ",$PIECE(^APCLVSTS(APCLCRIT,0),U)," selected, all will be included."
DO PAUSE
+9 IF $DATA(^XTMP("APCLVL",$JOB,"QMAN","*"))
KILL ^XTMP("APCLVL",$JOB,"QMAN")
WRITE !!,"All diagnosis will be included."
DO PAUSE
+10 ;now get relation
+11 KILL DIC
+12 KILL APCLREL
DO GETREL
+13 IF '$ORDER(APCLREL(0))
WRITE !!,"No relationships selected, ANY non-null relationship will be included."
DO PAUSE
+14 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+15 IF '$DATA(^XTMP("APCLVL",$JOB,"QMAN"))
Begin DoDot:1
+16 SET X=""
+17 IF '$DATA(APCLREL)
SET Z=""
SET Y=Y+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
QUIT
+18 SET Z=0
FOR
SET Z=$ORDER(APCLREL(Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+19 SET Y=Y+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
End DoDot:2
End DoDot:1
GOTO Q1
+20 ;
+21 SET X=""
SET Y=0
FOR
SET X=$ORDER(^XTMP("APCLVL",$JOB,"QMAN",X))
IF X=""
QUIT
Begin DoDot:1
+22 IF '$DATA(APCLREL)
SET Z=""
SET Y=Y+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
QUIT
+23 SET Z=0
FOR
SET Z=$ORDER(APCLREL(Z))
IF Z'=+Z
QUIT
Begin DoDot:2
+24 SET Y=Y+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X_"-"_Z
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X_"-"_Z,Y)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
End DoDot:2
End DoDot:1
Q1 KILL X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
+1 KILL ^XTMP("APCLVL",$JOB,"QMAN")
+2 KILL APCLREL,DIR
+3 QUIT
GETREL ;
+1 KILL DIR
+2 SET DIR(0)="9000014.1,.01O"
SET DIR("A")="ENTER PCC RELATIONSHIP"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(DIRUT)
QUIT
+4 IF Y=-1
QUIT
+5 IF Y=""
QUIT
+6 SET APCLREL(+Y)=""
+7 GOTO GETREL
+8 QUIT
APPTS ;EP - Appointments
+1 ;get date range as pieces 1 and 2 and clinics as pieces 3-99 or 3rd piece blank if any clinic
+2 ;beginning and ending date
+3 NEW APCLBDAT,APCLEDAT,APCLSDAT,APCLCLN,APCLT
APPTBD ;get beginning date
+1 WRITE !
SET DIR(0)="D^::EP"
SET DIR("A")="Enter beginning Appointment date for Search"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 SET APCLBDAT=Y
APPTED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCLBDAT_"::EP"
SET DIR("A")="Enter ending Appointment date for Search"
SET Y=APCLBDAT
DO DD^%DT
SET DIR("B")=Y
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO APPTBD
+3 SET APCLEDAT=Y
+4 SET X1=APCLBDAT
SET X2=-1
DO C^%DTC
SET APCLSDAT=X_".9999"
+5 ;get clinics
APPCLNS ;
+1 KILL APCLCLN
+2 SET APCLT=""
+3 SET DIR(0)="S^A:ANY Clinic (All Clinics);S:Selected Set of Clinics"
SET DIR("A")="Which Appointment Clinics should be included"
SET DIR("B")="S"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !!,"No Clinics chosen....item will not be used as a selection item..."
DO PAUSE
QUIT
+5 IF Y="A"
GOTO SETAPPT
+6 ;
+7 KILL APCLCLN
APPCLNS1 ;
+1 SET DIR(0)="9001003.7,999916"
SET DIR("A")="Enter APPOINTMENT CLINIC"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
IF '$ORDER(APCLCLN(0))
WRITE !!,"No clinics chosen...."
GOTO APPCLNS
+3 IF Y=""
IF '$ORDER(APCLCLN(0))
WRITE !!,"No clinics chosen...."
GOTO APPCLNS
+4 IF Y
SET APCLCLN(+Y)=""
GOTO APPCLNS1
SETAPPT ;
+1 KILL APCLCLN
+2 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+3 SET APCLCNT=0
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
+4 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT
+5 SET C=2
SET X=0
FOR
SET X=$ORDER(APCLCLN(X))
IF X'=+X
QUIT
SET C=C+1
SET $PIECE(^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0),U,C)=X
+6 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
+7 QUIT
PLDOO ;EP - Appointments
+1 ;get date range as pieces 1 and 2 and clinics as pieces 3-99 or 3rd piece blank if any clinic
+2 ;beginning and ending date
+3 NEW APCLBDAT,APCLEDAT,APCLSDAT,APCLCLN,APCLT
PLDOOBD ;get beginning date
+1 WRITE !
SET DIR(0)="D^::EP"
SET DIR("A")="Enter beginning Date of Onset for Search"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 SET APCLBDAT=Y
PLDOOED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCLBDAT_"::EP"
SET DIR("A")="Enter ending Date of Onset date for Search"
SET Y=APCLBDAT
DO DD^%DT
SET DIR("B")=Y
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO PLDOOBD
+3 SET APCLEDAT=Y
+4 SET X1=APCLBDAT
SET X2=-1
DO C^%DTC
SET APCLSDAT=X_".9999"
+5 ;get clinics
PLDXS ;
+1 KILL APCLPDOO
+2 SET APCLT=""
+3 SET DIR(0)="S^A:ANY Diagnosis;S:Selected Set of Diagnoses"
SET DIR("A")="Which Problem List Diagnoses should be included"
SET DIR("B")="S"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
WRITE !!,"No dx chosen....item will not be used as a selection item..."
DO PAUSE
QUIT
+5 IF Y="A"
GOTO SETPLDOO
+6 ;
+7 KILL APCLPDOO
PLDXS1 ;
+1 KILL AMQQTAXN
+2 KILL ^XTMP("APCLVL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB)
+3 KILL DIC,X,Y,DD
SET X="DIAGNOSIS"
SET DIC="^AMQQ(5,"
SET DIC(0)="EQXM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA,DINUM,DICR
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
QUIT
+4 SET APCLQMAN=+Y
+5 DO PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
+6 IF '$DATA(^XTMP("APCLVL",$JOB,"QMAN"))
WRITE !!,$CHAR(7),"** No ",$PIECE(^APCLVSTS(APCLCRIT,0),U)," selected."
GOTO PLDXS
+7 IF $DATA(^XTMP("APCLVL",$JOB,"QMAN","*"))
KILL ^XTMP("APCLVL",$JOB,"QMAN")
WRITE !!,"*** All items selected, if you want all then choose ANY diagnosis."
GOTO PLDXS
+8 SET X=""
SET Y=0
FOR
SET X=$ORDER(^XTMP("APCLVL",$JOB,"QMAN",X))
IF X=""
QUIT
SET APCLPDOO(X)=""
Q11 KILL X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
+1 KILL ^XTMP("APCLVL",$JOB,"QMAN")
SETPLDOO ;
+1 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+2 SET APCLCNT=0
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
+3 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT
+4 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
+5 QUIT
