- 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
