source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBGVST.m@ 836

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

initial load of WorldVistAEHR
File size: 6.0 KB
Line 
1PXBGVST ;ISL/JVS - GATHER ENCOUNTERS ;8/28/96
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**1**;Aug 12, 1996
3 ;
4 ;
5 ;
6VISITLST(DFN,BEGINDT,ENDDT,HLOC,SCREEN,APPOINT,PROMPT,COSTATUS) ;--GATHER VISITS
7 ;
8 ; DFN = Patient Identification entry number (required)
9 ; BEGINDT = Begining date of date range-INTERNAL FORMAT (optional)
10 ; ENDDT = Ending date of date range-INTERNAL FORMAT (optional)
11 ; HLOC = Hospital Location (pointer to file#44) (optional)
12 ; SCREEN = Code as related to field 15003 (optional)
13 ;
14 ; ..'A'=ANCILLARY
15 ; ..'P'=PRIMARY
16 ; ..'O'=OCCASION OF SERIVCE
17 ; ..'S'=STOP CODES
18 ; ..'X'=All three above plus the 'NULL' Encounters (DEFAULT)
19 ;
20 ; ..'E'=Historical Encounters ('XE' for all historical visits)
21 ;
22 ; APPOINT
23 ; ..-1
24 ; ..0
25 ; ..1
26 ; OUTPUT:
27 ; >0 = VISIT IEN
28 ; =0 = User selected to add a visit
29 ; -1 = No visit selected
30 ; -2^"TEXT" = error of some kind^mesage about error
31 ;
32 ;
33 ;--Validate A PATIENT visit is sent in
34 I $G(DFN)<1 Q -2_"^"_"NO PATIENT"
35 I '$D(^AUPNPAT(DFN)) Q -2_"^"_"NO SUCH PATIENT"
36 ;
37 ;--If no date range then default it
38 I BEGINDT<1500000!(ENDDT<1500000) D
39 . N X1,X2,%H,%T
40 . S X1=DT,X2=+$P(^PX(815,1,"LM"),"^",3) D C^%DTC S BEGINDT=$S(BEGINDT>X:BEGINDT,1:X)
41 . S X1=DT,X2=+$P(^PX(815,1,"LM"),"^",4) D C^%DTC S ENDDT=X
42 ;
43 N STOP
44 I $G(HLOC) D Q:$G(STOP) -2_"^"_"NO SUCH HOSPITAL LOCATION"
45 .I '$D(^SC(HLOC)) S STOP=1
46 ;
47 ;--NEW variables
48 N IEN,INDATEI,INDATEE,PXBC,PXBCC,VST,PXBI,SCRN,SCRN1,ENDDTT,BEGINDTT
49 N PXBHIGH,PXBCNT,PXBWIN,PXBSAVE,PXBDT,DEL,NOD0,NOD150,UID,STATUS
50 N HLOCE,HLOCI,VAL,VAR
51 S (PXBC,PXBCC)=0
52 ;--KILL variables
53 K ^TMP("PXBU",$J),^UTILITY("DIQ1",$J),^TMP("PXBKY",$J),^TMP("PXBSAM",$J),^TMP("PXBSKY",$J),GROUP
54 ;--CREATE tmp global
55 ;-SET UP SCREEN
56 I $D(SCREEN) D
57 .S PXBI="" F PXBI=1:1:$L(SCREEN) S SCRN($E(SCREEN,PXBI))=""
58 .I '$D(SCRN) S SCRN("X")=""
59 I $D(^AUPNVSIT("AA",DFN)) D
60 .I $G(ENDDT) S ENDDTT=9999999-$P(ENDDT,".",1) S:ENDDT["." ENDDTT=ENDDTT_((ENDDT#1)-(.0001)) S:ENDDT'["." ENDDTT=(ENDDTT)-(.0001) S ENDDT=ENDDTT
61 .I $G(BEGINDT) S BEGINDTT=9999999-$P(BEGINDT,".",1) S:BEGINDT["." BEGINDTT=BEGINDTT_(BEGINDT#1) S:BEGINDT'["." BEGINDTT=BEGINDTT_".999999" S BEGINDT=BEGINDTT
62 .I '$G(BEGINDT) S BEGINDT=999999999
63 .S PXBDT=$S($G(ENDDT):ENDDT,1:"")
64 .F S PXBDT=$O(^AUPNVSIT("AA",DFN,PXBDT)) Q:PXBDT>BEGINDT Q:PXBDT'>0 D
65 ..S IEN=0 F S IEN=$O(^AUPNVSIT("AA",DFN,PXBDT,IEN)) Q:IEN="" D
66 ...;
67 ...;-----SCREEN-------
68 ...;----BRING IN ALL NODES
69 ...S NOD0=$G(^AUPNVSIT(IEN,0)),NOD150=$G(^AUPNVSIT(IEN,150))
70 ...;--SCREEN OUT HISTORICAL VISITS
71 ...I $D(SCRN("E")),$P(NOD0,"^",7)'="E" Q
72 ...I '$D(SCRN("E")),$P(NOD0,"^",7)="E" Q
73 ...;--SCREEN BASED ON PARAMETER
74 ...S SCRN1=$P(NOD150,"^",3)
75 ...I SCRN1="",'$D(SCRN("X")) Q
76 ...I $D(SCRN("X")) G CON
77 ...I SCRN1="A",'$D(SCRN("A")) Q
78 ...I SCRN1="O",'$D(SCRN("O")) Q
79 ...I SCRN1="P",'$D(SCRN("P")) Q
80 ...I SCRN1="S",'$D(SCRN("S")) Q
81 ...I SCRN1="C",'$D(SCRN("C")) Q
82CON ...;--CONTINUE
83 ...;--HOSPITAL LOCATION
84 ...I $G(HLOC) Q:$P(NOD0,"^",22)'=HLOC
85 ...I $G(APPOINT)=0 G END
86 ...;--I RELATED TO APPOINTMENT--APPOINT=1
87 ...;I $G(APPOINT)>0,$P(NOD0,"^",22)'=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
88 ...I $G(APPOINT)>0,'$$VSTAPPT^PXUTL1(DFN,$P(NOD0,"^",1),$P(NOD0,"^",22),IEN) Q
89 ...;--I NOT RELATED TO AN APPOINTMENT--APPOINT=-1
90 ...;I $G(APPOINT)<0,$P(NOD0,"^",22)=+$G(^DPT(DFN,"S",$P(NOD0,"^",1),0)) Q
91 ...I $G(APPOINT)<0,$$VSTAPPT^PXUTL1(DFN,$P(NOD0,"^",1),$P(NOD0,"^",22),IEN) Q
92END ...;---END OF SCREENS-----
93 ...;--DISPOSITIONS
94 ...I $$DISPOSIT^PXUTL1(DFN,$P(NOD0,"^",1),IEN) Q
95 ...;
96 ...S PXBC=PXBC+1
97 ...S ^TMP("PXBU",$J,"VST",IEN)=""
98 K SCRN,SCRN1
99 ;
100 ;
101A ;--Set array with the VISITS from the visits
102 N DIQ,PRIME,PRIMI,PXBDT,VSTDTE,VSTDTI,GROUP
103 I $D(^TMP("PXBU",$J,"VST")) D
104 .S IEN=0 F S IEN=$O(^TMP("PXBU",$J,"VST",IEN)) Q:IEN'>0 D
105 ..S DIC=9000010,DR=".01;.22;15003;15001",DA=IEN,DIQ(0)="EI" D EN^DIQ1
106 ..S VSTDTE=$G(^UTILITY("DIQ1",$J,9000010,DA,.01,"E"))
107 ..S VSTDTE=$P(VSTDTE,"@",1)_" "_$P($P(VSTDTE,"@",2),":",1,2)
108 ..S VSTDTI=$G(^UTILITY("DIQ1",$J,9000010,DA,.01,"I"))
109 ..S HLOCE=$G(^UTILITY("DIQ1",$J,9000010,DA,.22,"E"))
110 ..S HLOCI=$G(^UTILITY("DIQ1",$J,9000010,DA,.22,"I"))
111 ..S PRIME=$G(^UTILITY("DIQ1",$J,9000010,DA,15003,"E"))
112 ..S PRIMI=$G(^UTILITY("DIQ1",$J,9000010,DA,15003,"I"))
113 ..S UID=$G(^UTILITY("DIQ1",$J,9000010,DA,15001,"E"))
114 ..S STATUS=$P($$STATUS^SDPCE(IEN),"^",2)
115 ..S GROUP=VSTDTE_"^"_VSTDTI_"^"_HLOCE_"^"_HLOCI_"^"_PRIME_"^"_PRIMI_"^"_UID_"^"_STATUS
116 ..S ^TMP("PXBVSTG",$J,VSTDTI,IEN)=GROUP
117 K DIC,DR,DA
118 ;
119 ;
120B ;--ADD Line Numbers
121 I $D(^TMP("PXBVSTG",$J)) D
122 .S PXBCC=PXBC+1,VST="" F S VST=$O(^TMP("PXBVSTG",$J,VST)) Q:VST="" D
123 ..S IEN=0 F S IEN=$O(^TMP("PXBVSTG",$J,VST,IEN)) Q:IEN="" S PXBCC=PXBCC-1 D
124 ...S ^TMP("PXBKY",$J,VST,PXBCC)=$G(^TMP("PXBVSTG",$J,VST,IEN))
125 ...S ^TMP("PXBSAM",$J,PXBCC)=$G(^TMP("PXBVSTG",$J,VST,IEN))
126 ...S ^TMP("PXBSKY",$J,PXBCC,IEN)=""
127 ;
128F ;--FINISH UP THE VARIABLES
129 K ^TMP("PXBU",$J),^UTILITY("DIQ1",$J)
130 S PXBCNT=+$G(PXBC)
131 D DISP
132 Q VAL
133 ;
134 ;---GO TO PROMPTING
135DISP ;--DISPLAY
136 ;---------------NEW CURSOR CONTROL VARIABLE-----------------------
137 N IOARM0,IOARM1,IOAWM0,IOAWM1,IOBOFF,IOBON,IOCOMMA,IOCUB,IOCUD,IOCUF
138 N IOCUON,IOCUOFF,IOCUU,IODCH,IODHLB,IODHLT,IODL,IODWL,IOECH,IOEDALL
139 N IOEDBOP,IOEDEOP,IOEFLD,IOELALL,IOELBOL,IOELEOL,IOENTER,IOFIND
140 N IOHDWN,IOHOME,IOHTS,IOHUP,IOICH,IOIL,IOIND,IOINHI,IOINLOW,IOINORM
141 N IOINSERT,IOKP0,IOKP1,IOKP2,IOKP3,IOKP4,IOKP5,IOKP6,IOKP7,IOKP8,IOKP9
142 N IOIRM0,IOIRM1,IOKPAM,IOKPNM,IOMC,IOMINUS,IONEL,IONEXTSC,IOPERIOD
143 N IOPF1,IOPF2,IOPF3,IOPF4,IOPREVSC,IOPROB,IOPTCH10,IOPTCH12,IOPTCH16
144 N IORC,IOREMOVE,IORESET,IORI,IORVOFF,IORVON,IOSC,IOSGR0,IOSELECT
145 N IOSTBM,IOSWL,IOTBC,IOTBCALL,IOUOFF,IOUON,IOIS
146 ;
147 ;------------------------*******----------------------------------
148 D TERM^PXBCC
149 D FIX1^PXBCC
150 D HDR3^PXBUTL(DFN,1)
151 D REQ^PXBDREQ(8)
152 D EN0^PXBDVST
153 D LOC^PXBCC(15,0)
154 D WIN17^PXBCC(PXBCNT)
155 D VST^PXBPVST
156 D FULL0^PXBCC
157 D CLEAR1^PXBCC
158 K ^TMP("PXBKY",$J),^TMP("PXBSAM",$J),^TMP("PXBSKY",$J),^TMP("PXBVSTG",$J),^TMP("PXBU",$J),^TMP("PXBDVST",$J)
159 ;
160 ;
161 Q
162 ;---END OF PROMPTING
Note: See TracBrowser for help on using the repository browser.