source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRSRCH.m@ 1245

Last change on this file since 1245 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1IMRSRCH ;ISC-SF/JLI,HCIOFO/FT-CREATE SEARCH LIST FOR IMR MEMBERS IN PT FILE ;10/16/97 16:20
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;;Feb 09, 1998
3 ;[IMR SEARCH TEMPLATE] - Create Search Template Containing Study Members
4 I '$D(^XUSEC("IMRA",DUZ)) S IMRLOC="IMRSRCH" D ACESSERR^IMRERR,H^XUS
5TOP S IMRTNAM="",IMROUT=0,IMRDONE=0
6 F I=0:0 Q:IMROUT!IMRDONE S IMRTNAM=$O(^DIBT("F158.90",IMRTNAM)) Q:IMRTNAM="" F J=0:0 S J=$O(^DIBT("F158.90",IMRTNAM,J)) Q:J'>0 I $D(^DIBT(J,0)),$P(^(0),U,5)=DUZ S X=$P(^(0),U,2) D CHEK Q:IMROUT I "Yy"[X S IMRDONE=1 Q
7 G:IMROUT EXIT S DA=$S(IMRTNAM="":-1,1:J)
8ASK I DA'>0 W !,"Enter a non-descriptive sort template name that will contain the patient",!,"identities: " R X:DTIME G:'$T!(X[U)!(X="") EXIT S IMRTNAM=X I X["?" D QUERY G ASK
9 I $D(^DIBT("F2",IMRTNAM)),'IMRDONE S DA=$O(^DIBT("F2",IMRTNAM,0)) W !,$C(7),"THERE IS ALREADY DATA STORED IN THAT TEMPLATE -- REPLACE ?? NO// " R Y:DTIME G:'$T!(Y[U) EXIT S:Y="" Y="N" S Y=$E(Y),IMRDONE=1 I "Yy"'[Y S DA=-1,IMRDONE=0 G ASK
10 I DA'>0 S X=""""_IMRTNAM_"""",DIC=.401,DIC(0)="L",DLAYGO=.401 D ^DIC G:Y'>0 EXIT S DA=+Y
11 W:'$D(ZTQUEUED) ! S DIE=.401,DR="2///T;"_$S(IMRDONE:"",1:"4///2;")_"5///"_DUZ_";7///T;" D ^DIE
12 K ^DIBT(DA,1) S ^DIBT("F158.90",IMRTNAM,DA)=""
13 K DIR S DIR(0)="Y",DIR("A")="Do you want to Queue this task (it may take a while) ",DIR("B")="YES" D ^DIR K DIR
14 I Y S ZTRTN="DQSRCH^IMRSRCH",ZTIO="",ZTDESC="Generate Search List",ZTSAVE("DA")="",ZTSAVE("IMRSTN")="",ZTSAVE("IMRTNAM")="" D ^%ZTLOAD K ZTRTN,ZTSK,ZTIO,ZTDESC,ZTSAVE G EXIT
15 W !,"Well, All right.... I'm working as fast as I can...",!
16DQSRCH ;
17 F I=0:0 S I=$O(^IMR(158,I)) Q:I'>0 S X=$P(^(I,0),U) D ^IMRXOR S ^DIBT(DA,1,X)="" W:'$D(ZTQUEUED) "."
18 I '$D(ZTQUEUED) W !!,"The entries are now stored in the template [",IMRTNAM,"]",!,"for use with the FileMan PRINT option",!
19 ;
20EXIT K %,%DT,DQ,DA,DIE,DIC,DR,I,DLAYGO,IMRLOC,IMROUT,IMRDONE,IMRTNAM,DIK,IMRX,J,Y,IMRSTN,D,D0,DI,X,X1,DISYS,POP,DIR,DIROUT,DIRUT,DTOUT,DUOUT
21 Q
22QUERY ;
23 W !!,"Enter a Name by which the search template for the PATIENT file can be",!,"identified. This should probably not include HIV or other HIV specific",!,"text.",!
24 Q
25 ;
26CHEK ;
27 W !!,"You already have the search template [",IMRTNAM,"]",!,"from ",$E(X,4,5),"-",$E(X,6,7),"-",$E(X,2,3),!!,"Do you wish to UPDATE it? YES// "
28 S IMROUT=0 R Z:DTIME S:'$T!(Z[U) IMROUT=1 Q:IMROUT S:Z="" Z="Y" S Z=$E(Z) I "YyNn"'[Z W:Z'="?" $C(7)," ??" W !?10,"Enter YES to update the template, NO to keep it as is, ^ to exit" G CHEK
29 S X=Z K Z
30 Q
31 ;
32SHOW ;[IMR TEMPLATE LIST] - List Search Templates for Package
33 ; Show search templates for IMR file, with user, date created,
34 ; last date used
35 S IMRDONE=0,IMRTNAM="",IMROUT=0
36 W:$Y>0 @IOF
37 W !,"Template List as of ",$$FMTE^XLFDT($$NOW^XLFDT(),1),!
38 F I=0:0 S IMRTNAM=$O(^DIBT("F158.90",IMRTNAM)) Q:IMRTNAM=""!(IMROUT) F J=0:0 S J=$O(^DIBT("F158.90",IMRTNAM,J)) Q:J'>0!(IMROUT) D SHOW1
39 I 'IMROUT D PRTC
40 W ! D EXIT
41 Q
42 ;
43SHOW1 I '$D(^DIBT(J,0)) K ^DIBT(J),^DIBT("F158.90",IMRTNAM,J),^DIBT("F2",IMRTNAM,J) Q
44 I 'IMRDONE W !!,"TEMPLATE NAME",?30,"CREATED BY",?60,"CREATED",?69,"LAST USED",! S IMRDONE=1
45 S X=^DIBT(J,0),X1=$P(X,U,2),X2=$P(X,U,7),X3=$P(X,U,5),X3=$S('$D(^VA(200,+X3,0)):"UNKNOWN",1:$P(^(0),U))
46 I $Y>(IOSL-4) D PRTC Q:IMROUT W @IOF
47 W !,$P(X,U),?30,X3,?60,$E(X1,4,5),"-",$E(X1,6,7),"-",$E(X1,2,3),?70,$E(X2,4,5),"-",$E(X2,6,7),"-",$E(X2,2,3)
48 K X,X1,X2,X3
49 Q
50 ;
51DELETE ;[IMR TEMPLATE DELETE] - Delete a Package Search Template
52 R !!,"Enter Template Name containing Immunology Study Patients: ",X:DTIME
53 G:'$T!(X="")!(X[U) EXIT
54 K DA S DA=0
55 I $D(^DIBT("F158.90",X)) S DA=DA+1,DA(DA,+$O(^(X,0)))=X
56 S X1=X
57 F I=0:0 S X=$O(^DIBT("F158.90",X)) Q:X=""!($E(X,1,$L(X1))'=X1) S DA=DA+1,DA(DA,+$O(^(X,0)))=X
58 I DA'>0 W:$E(X1)'="?" $C(7)," ??" W !,"Select from:" D SHOW G DELETE
59 I DA=1 S J=$O(DA(1,0)),X=DA(1,J) S X=$E(X,$L(X1)+1,$L(X)) W:X'="" X,!
60ASKDEL I DA>1 W !!,"Select from:" F I=1:1:DA S J=$O(DA(I,0)),X=DA(I,J) W !?10,$J(I,2)," ",X
61 I DA>1 W !!,"Select from 1 to ",DA,": " R X:DTIME Q:'$T!(X="")!(X[U) G:X'=+X!(X<1)!(X>DA) ASKDEL S J=$O(DA(X,0)),DA(1,J)=DA(X,J),DA=1
62 S J=$O(DA(1,0)),IMRX=DA(1,J)
63 W !!,"Ready to DELETE the template ",IMRX," (Y/N)? N//" R X:DTIME
64 Q:'$T!(X[U)
65 S:X="" X="N" S X=$E(X)
66 W:"YyNn"'[X $C(7),!,"Enter YES or NO or '^' to exit"
67 G:"YyNn"'[X ASKDEL
68 I "Nn"[X W $C(7),!!?20,"NOTHING DELETED" G DELETE
69 K DA S DA=J,DIK="^DIBT(" D ^DIK
70 K ^DIBT("F158.90",IMRX)
71 G DELETE
72PRTC ; press return to continue
73 Q:$E(IOST)'="C"
74 Q:$D(IO("S"))
75 K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DIRUT)!(Y=0) IMROUT=1
76 Q
Note: See TracBrowser for help on using the repository browser.