source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGQPT.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1DGQPT ; SLC/MKB - Patient Selection ;8/8/97 13:07
2 ;;5.3;Registration;**447**;Aug 13, 1993
3 ;
4 ; SLC/PKS - 3/2000: Modified to deal with "Combinations."
5 ;
6EN ; -- main entry point for DG PATIENT SELECTION
7 I $G(DGVP),'($D(DGPNM)&$D(DGSSN)) K DGVP ; reset
8 D EN^VALM("DG PATIENT SELECTION")
9 Q
10 ;
11HDR ; -- header code
12 N X I '$G(DGVP) S X="** No patient selected **"
13 E S X=$G(DGPNM)_" "_$G(DGSSN)
14 S VALMHDR(1)="Current patient: "_X
15 Q
16 ;
17INIT ; -- init variables and list array
18 ; Modifications for multiple "Combination" lists by PKS.
19 ;
20 ; PARAM herein might end up as: DGLP DEFAULT CLINIC WEDNESDAY
21 ; (Param Name and current DOW)
22 ; DGY might end up passed as: 5^5^C;1;T-360;T+60;A
23 ; (#lines^#pts^source;serviceSection;startDate;stopDate;sort)
24 ;
25 N DGY,DGX,PARAM,DGYZB,DGYZE
26 ;
27 ;added by CLA 12/12/96 - gets SERVICE/SECTION of user:
28 N DGSRV S DGSRV=$G(^VA(200,DUZ,5)) I +DGSRV>0 S DGSRV=$P(DGSRV,U)
29 ;
30 S DGY=$$GET^XPAR("USR^SRV.`"_$G(DGSRV),"DGLP DEFAULT LIST SOURCE",1,"I") ; Gets default list source for this user.
31 I $L(DGY) D S DGY=DGY_";"_DGX
32 . ; PKS: Set "PARAM" var to parameter name in param def file:
33 . S PARAM="DGLP DEFAULT "_$S(DGY="T":"TEAM",DGY="S":"SPECIALTY",DGY="P":"PROVIDER",DGY="W":"WARD",DGY="C":"CLINIC",DGY="M":"COMBINATION",1:"")
34 . S:DGY="C" PARAM=PARAM_" "_$$UP^XLFSTR($$DOW^XLFDT(DT)) ; For clinics, add current DOW.
35 . S DGX=$$GET^XPAR("USR^SRV.`"_$G(DGSRV),PARAM,1,"I") ; Source param.
36 . ; Next lines modified by PKS for "Combinations" and dates:
37 . I (DGY="C")!(DGY="M") D
38 . . S DGYZB=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC START DATE",1,"I")) ; Gets clinic start date.
39 . . I DGYZB="T+0" S DGYZB=$$FMTE^XLFDT(DT,DGYZB)
40 . . S DGX=DGX_";"_DGYZB
41 . . S DGYZE=$$UP^XLFSTR($$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT CLINIC STOP DATE",1,"I")) ; Add ";" & stop date.
42 . . I DGYZE="T+0" S DGYZE=$$FMTE^XLFDT(DT,DGYZE)
43 . . S DGX=DGX_";"_DGYZE
44 S $P(DGY,";",5)=$$GET^XPAR("USR^SRV.`"_$G(DGSRV)_"^DIV^SYS^PKG","DGLP DEFAULT LIST ORDER",1,"I") ; Add default sort order.
45 ;
46 ; Call tag that builds the actual Patient Selection List:
47 D BUILD(DGY)
48 Q
49 ;
50DEFAULT() ; -- Returns default action
51 I '$P($G(^TMP("DG",$J,"PATIENTS",0)),U,2) Q "Change View"
52 I XQORM("B")="Quit" Q "Close"
53 Q "Next Screen"
54 ;
55MSG() ; -- Lmgr msg bar
56 Q "Enter the number of the patient chart to be opened"
57 ;
58HELP ; -- help code
59 N X D FULL^VALM1 S VALMBCK="R"
60 W !!,"Enter the display number of the patient whose chart you wish to open"
61 W !,"or enter a patient name, SSN, or initial/last 4 combination. To"
62 W !,"change the list of patients displayed on this screen, enter CV. To"
63 W !,"have the new list automatically displayed when selecting a new patient,"
64 W !,"enter SV. Enter FD to search by patient name or identifier."
65 W !!,"Press <return> to continue ..." R X:DTIME
66 Q
67 ;
68EXIT ; -- exit code
69 K ^TMP("DG",$J,"PATIENTS"),XQORM("ALT")
70 Q
71 ;
72BUILD(LIST) ; -- build list in ^TMP("DG",$J,"PATIENTS")
73 N DGI,DGX,DGY,LCNT,NUM,DFN,NAME,TYPE,PTR,BEG,END,SORT,DOB,RBED,%DT,X,Y,TITLE,PTID,SENS
74 S TYPE=$E(LIST),PTR=+$P(LIST,";",2),SORT=$P(LIST,";",5)
75 ; Next 5 lines added by PKS:
76 I ((SORT="S")&(TYPE'="M")) S SORT="A" ; Reset invalid sorts.
77 I TYPE="M" D ; Deal with combinations.
78 .I ((SORT="P")!(SORT="A")!(SORT="S")) Q ; P,A,S are acceptable.
79 .S SORT="A" ; Default.
80 S $P(LIST,";",5)=SORT ; Reset in case of change.
81 S BEG=$P(LIST,";",3) I $L(BEG) S X=BEG,%DT="X" D ^%DT S BEG=Y
82 S END=$P(LIST,";",4) I $L(END) S X=END,%DT="X" D ^%DT S END=Y
83 I TYPE="T" D TEAMPTS^DGQPTQ1(.DGY,PTR) S TITLE="Team "_$P($G(^OR(100.21,+PTR,0)),U)
84 I TYPE="P" D PROVPTS^DGQPTQ2(.DGY,PTR) S TITLE="Provider "_$P($G(^VA(200,+PTR,0)),U)
85 I TYPE="S" D SPECPTS^DGQPTQ2(.DGY,PTR) S TITLE="Specialty "_$P($G(^DIC(45.7,+PTR,0)),U)
86 I TYPE="W" D WARDPTS^DGQPTQ2(.DGY,PTR) S TITLE="Ward "_$P($G(^DIC(42,+PTR,0)),U)
87 I TYPE="C" D CLINPTS^DGQPTQ2(.DGY,PTR,BEG,END) S TITLE="Clinic "_$P($G(^SC(+PTR,0)),U)
88 ; Next line added by PKS for "Combinations:"
89 I TYPE="M" N MSG D COMBPTS^DGQPTQ6(1,PTR,BEG,END) S TITLE="Combination List" ; Sets MSG,LCNT,NUM, and writes ^TMP("DG",$J,"PATIENTS").
90 ; Next section added by PKS for "Combinations:"
91 I TYPE="M" D G BQ ; Check MSG var, then go to BQ tag.
92 .I MSG'="" D ; Did call to COMBPTS assign an error message?
93 ..S LCNT=1,NUM=0 ; Set defaults.
94 ..S ^TMP("DG",$J,"PATIENTS",1,0)=" "_MSG ; Write error msg.
95 D CLEAN^VALM10 S (LCNT,NUM)=0 ; All but "M" types reset, go on to B1.
96 ;
97B1 S DGI=0 F S DGI=$O(DGY(DGI)) Q:DGI'>0 I DGY(DGI) D ; sort
98 . S DFN=+DGY(DGI)
99 . ;sort logic added by CLA 7/23/97:
100 . S DGX=""
101 . I SORT="P",(TYPE="C") S DGX=$P($G(DGY(DGI)),U,4) D
102 .. S $P(DGX,".",2)=$E($P(DGX,".",2)_"000",1,4)
103 ..S DGX=DGX_U_$P(DGY(DGI),U,2)
104 . I SORT="R",(TYPE'="C") S DGX=$P($G(^DPT(+DGY(DGI),.101)),U)_U_$P(DGY(DGI),U,2)
105 . I SORT="T" S DGX="" ; Need to add terminal digit sorting.
106 . ; If no sort specified, default to alphabetic (plus app't if clinic type):
107 . I DGX="" S DGX=$P(DGY(DGI),U,2)_U_$P($G(DGY(DGI)),U,4)
108 . S ^TMP("DG",$J,"PATIENTS","B",DGX_DFN)=DGY(DGI) ; DFN ^ Name
109 I '$D(^TMP("DG",$J,"PATIENTS")) D G BQ
110 . N MSG
111 . S MSG="No patients found"
112 . S LCNT=1,NUM=0
113 . I $D(DGY(1)) S MSG=$P(DGY(1),"^",2) ; error message from search
114 . S ^TMP("DG",$J,"PATIENTS",1,0)=" "_MSG
115B2 S DGX="" F S DGX=$O(^TMP("DG",$J,"PATIENTS","B",DGX)) Q:DGX="" S DGY=^(DGX) D
116 . S DFN=+DGY,NAME=$P(DGY,U,2)
117 . S DOB=$$FMTE^XLFDT($P($G(^DPT(DFN,0)),U,3))
118 . S:(TYPE'="C") RBED=$P($G(^DPT(DFN,.101)),U)
119 . I (TYPE="C") S RBED=$S(SORT="P":$$FMTE^XLFDT($P(DGX,U)),1:$$FMTE^XLFDT($P(^TMP("DG",$J,"PATIENTS","B",DGX),U,4)))
120 . ;Q:RBED="" removed by CLA 7/23/97 to prevent blank lines
121 . S LCNT=LCNT+1,NUM=NUM+1
122 . S ^TMP("DG",$J,"PATIENTS","IDX",NUM)=DGY ; DFN ^ NAME
123 . ; Next lines modified/added by PKS on 1/24/2001:
124 . ; Check for "sensitive" patients:
125 . S PTID=""
126 . S PTID=$$ID(DFN)
127 . S SENS=$$SSN^DPTLK1(DFN)
128 . I SENS["*" S PTID=""
129 . S DOB=$$DOB^DPTLK1(DFN)
130 . S ^TMP("DG",$J,"PATIENTS",LCNT,0)=$$LJ^XLFSTR(NUM,5)_$$LJ^XLFSTR(NAME,31)_$$LJ^XLFSTR(PTID,10)_$$LJ^XLFSTR(DOB,15)_$G(RBED)
131 . D CNTRL^VALM10(LCNT,1,5,IOINHI,IOINORM)
132BQ S ^TMP("DG",$J,"PATIENTS",0)=LCNT_U_NUM_U_$G(LIST) ; #lines^#pts^context
133 S ^TMP("DG",$J,"PATIENTS","#")=$O(^ORD(101,"B","ORQPT SELECT PATIENT",0))_"^1:"_NUM
134 S RBED=$S(TYPE="C":"Appointment Date",TYPE="M":"Source Other",1:"Room-Bed")
135 D CHGCAP^VALM("ROOM-BED",RBED) K VALMHDR
136 S VALMCNT=LCNT,VALMBG=1,VALMBCK="R" S:$L($G(TITLE)) VALM("TITLE")=TITLE
137 Q
138 ;
139ID(DFN) ; -- Returns short ID for patient ID
140 N ID S ID=$P($G(^DPT(DFN,.36)),U,4) ; short ID
141 I '$L(ID) S ID=$E($P($G(^DPT(DFN,0)),U,9),6,9) ; last 4 of SSN
142 Q "("_$E(NAME)_ID_")"
143 ;
144APPT(DFN,CLINIC,FROM,TO) ; -- Return [next?] clinic appointment
145 N VASD,VAERR K ^UTILITY("VASD",$J)
146 S VASD("F")=FROM,VASD("T")=TO,VASD("C",CLINIC)=""
147 D SDA^VADPT S NEXT=+$O(^UTILITY("VASD",$J,0)),NEXT=$P($G(^(NEXT,"I")),U)
148 K ^UTILITY("VASD",$J)
149 Q NEXT
150 ;
151ALT ; -- XQORM("ALT") code to search File 2 for patient X
152 N DIC,DFN,Y,DGX S DGX=X D FULL^VALM1
153 S DIC=2,DIC(0)="EQM",X=$S($D(XQORMRCL):" ",1:DGX)
154 D ^DIC I Y'>0 S VALMBCK="R" Q ;S XQORMERR=1 Q
155 S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
156 S DFN=+Y G:DFN'=+$G(DGVP) SLCT1 ; set patient variables
157 Q
158 ;
159FIND ; -- find patient in ^DPT
160 N X,Y,DIC,DGX,DFN
161 S DIC=2,DIC(0)="AEQM" D FULL^VALM1
162 D ^DIC I Y'>0 S VALMBCK="R" Q
163 S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
164 S DFN=+Y G:DFN'=+$G(DGVP) SLCT1 ; set patient variables
165 Q
166 ;
167SELECT ; -- select patient from list
168 N NMBR,X,Y,Z,DIC,DFN,DGX S NMBR=+$P(XQORNOD(0),"=",2)
169 S Y=$G(^TMP("DG",$J,"PATIENTS","IDX",NMBR)),DFN=+Y
170 I 'DFN W $C(7),!!,NMBR_" is not a valid selection.",! S VALMBCK="" H 1 Q
171 ;W " "_$P(Y,U,2) S ^DISV(DUZ,"^DPT(")=DFN
172 D FULL^VALM1 S DIC=2,DIC(0)="EQM",X="`"_DFN D ^DIC I Y<0 S VALMBCK="R" Q
173 S DGX=+$G(^DPT(+Y,.35)) I DGX,'$$OK(DGX) S VALMBCK="R" Q
174SLCT1 ; -- may enter here with DFN from FIND
175 N VADM,VAEL,VAIN,VA,VAERR,LOC,ORCNV
176 D OERR^VADPT,ELIG^VADPT
177 S LOC=+$G(^DIC(42,+VAIN(4),44))_";SC(" I 'LOC,'$D(XQAID) D
178 . I $G(NMBR) N X S X=$$CONTEXT^DGQPT1 I $E(X)="C" S LOC=$P(X,";",2)_";SC(" Q:LOC ; use clinic if selected from list, else ask
179 . S LOC=""
180 S DGL=LOC,DGL(0)=$P($G(^SC(+DGL,0)),U),DGL(1)=VAIN(5)
181 S DGVP=DFN_";DPT(",DGPNM=VADM(1),DGSSN=$P(VADM(2),U,2)
182 S DGDOB=$P(VADM(3),U,2),DGAGE=VADM(4),DGSEX=$P(VADM(5),U)
183 S DGTS=+VAIN(3),DGWARD=VAIN(4),DGATTEND=+VAIN(11),DGSC=$G(VAEL(3))
184 I $P($G(^DGSL(38.1,+DGVP,0)),"^",2),($G(^DPT(+DGVP,.1))]""!$D(^XUSEC("DG SENSITIVITY",DUZ))) D
185 . ; if senstive patient and (patient inpatient or user holds key)
186 . ; prevents sensitive patient warning from scrolling off screen
187 . N X
188 . W !!,"Press <return> to continue ..."
189 . R X:DTIME
190SLCT2 ; -- convert patient's orders, if not already done
191 S DGCNV=$$OTF^OR3CONV(+DGVP) Q:'DGCNV I DGCNV>0 W !,"DONE" H 1 Q
192 I DGCNV<0 W $C(7),!!,$P(DGCNV,U,2) H 2 S VALMBCK="R" Q
193 Q
194 ;
195OK(DATE) ; -- Patient is deceased; ok to continue?
196 N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
197 S DIR("A")="Do you wish to continue? "
198 W $C(7),!!,"This patient died "_$$FMTE^XLFDT(DATE)_"!"
199 D ^DIR
200 Q +Y
Note: See TracBrowser for help on using the repository browser.