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

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

initial load of WorldVistAEHR

File size: 3.9 KB
RevLine 
[613]1DGENL2 ;ALB/RMO - Patient Enrollment - Build List Area Cont.;16 JUN 1997 ; 7/8/05 1:37pm
2 ;;5.3;Registration;**121,147,232,306,417,672**;Aug 13,1993
3 ;
4HIS(DGARY,DFN,DGENRIEN,DGLINE,DGCNT) ;Enrollment history
5 ; Input -- DGARY Global array subscript
6 ; DFN Patient IEN
7 ; DGENRIEN Enrollment IEN
8 ; DGLINE Line number
9 ; Output -- DGCNT Number of lines in the list
10 N DGENR,DGNUM,DGPRIEN,DGSTART
11 ;
12 S DGSTART=DGLINE ;starting line number
13 S DGNUM=0 ;selection number
14 D SET(DGARY,DGLINE,"Enrollment History",31,IORVON,IORVOFF,,,,.DGCNT)
15 ;
16 ;Enrollment date, status, priority, date/time entered
17 S DGLINE=DGLINE+1
18 D SET(DGARY,DGLINE," Effective Date Status Priority Date/Time Entered",5,,,,,,.DGCNT)
19 S DGLINE=DGLINE+1
20 D SET(DGARY,DGLINE,"===============================================================================",1,,,,,,.DGCNT)
21 S DGPRIEN=DGENRIEN
22 F S DGPRIEN=$$FINDPRI^DGENA(DGPRIEN) Q:'DGPRIEN D
23 . I $$GET^DGENA(DGPRIEN,.DGENR) D
24 . . S DGNUM=DGNUM+1
25 . . S DGLINE=DGLINE+1
26 . . D SET(DGARY,DGLINE,DGNUM,1,,,"EH",DGNUM,DGPRIEN,.DGCNT)
27 . . D SET(DGARY,DGLINE,$S($G(DGENR("EFFDATE")):$$EXT^DGENU("EFFDATE",DGENR("EFFDATE")),1:""),5,,,,,,.DGCNT)
28 . . D SET(DGARY,DGLINE,$S($G(DGENR("STATUS")):$E($$EXT^DGENU("STATUS",DGENR("STATUS")),1,19),1:""),25,,,,,,.DGCNT)
29 . . D SET(DGARY,DGLINE,$S($G(DGENR("PRIORITY")):DGENR("PRIORITY")_$$EXTERNAL^DILFD(27.11,.12,"F",$G(DGENR("SUBGRP"))),1:""),45,,,,,,.DGCNT)
30 . . D SET(DGARY,DGLINE,$S($G(DGENR("DATETIME")):$$EXT^DGENU("DATETIME",DGENR("DATETIME")),1:""),57,,,,,,.DGCNT)
31 Q
32 ;this SET subroutine is being moved to DGENL2 from DGENL1, which has
33 ;gotten too big. patch DG*5.3*653
34SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,DGCNT) ; -- set display array
35 ; Input -- DGARY Global array subscript
36 ; DGLINE Line number
37 ; DGTEXT Text
38 ; DGCOL Column to start at (optional)
39 ; DGON Highlighting on (optional)
40 ; DGOFF Highlighting off (optional)
41 ; DGSUB Secondary list subscript (optional)
42 ; DGNUM Selection number (optional)
43 ; DGDATA Data associated with selection (optional)
44 ; Output -- DGCNT Number of lines in the list
45 N X
46 S:DGLINE>DGCNT DGCNT=DGLINE
47 S X=$S($D(^TMP(DGARY,$J,DGLINE,0)):^(0),1:"")
48 S ^TMP(DGARY,$J,DGLINE,0)=$$SETSTR^VALM1(DGTEXT,X,DGCOL,$L(DGTEXT))
49 D:$G(DGON)]""!($G(DGOFF)]"") CNTRL^VALM10(DGLINE,DGCOL,$L(DGTEXT),$G(DGON),$G(DGOFF))
50 ;Set-up special index for secondary selection list
51 S:$G(DGSUB)]"" ^TMP(DGARY_"IDX",$J,DGSUB,DGNUM,DGLINE)=DGDATA,^TMP(DGARY_"IDX",$J,DGSUB,0)=DGNUM
52 Q
53PHEART(DFN,DGENRIEN,PHENRDT) ;find Purple Heart information based on enrollment date
54 N NXTENR,NXTENDT,PRVENR,PRVENDT,PHARY,PHI,PHST,PHRR,PHDIERR
55 N NXTDIF,NXTENTM,NXTPHDT,NXTPHTM,PHENTM,PHREC,PRVDIF,PRVPHDT
56 S U="^",(PRVDIF,NXTDIF)=""
57 Q:'(PHENRDT&DGENRIEN) ""
58 S PRVENDT=0,NXTENDT=9999999
59 S PRVENR=$O(^DGEN(27.11,"C",DFN,DGENRIEN),-1)
60 S:PRVENR PRVENDT=$P($G(^DGEN(27.11,PRVENR,"U")),U)
61 S PRVPHDT=$O(^DPT(DFN,"PH","B",PHENRDT),-1)
62 S NXTENR=$O(^DGEN(27.11,"C",DFN,DGENRIEN))
63 S:NXTENR NXTENDT=$P($G(^DGEN(27.11,NXTENR,"U")),U)
64 S NXTPHDT=$O(^DPT(DFN,"PH","B",PHENRDT-.0000001))
65 I NXTPHDT<NXTENDT,$P(PHENRDT,".")=$P(NXTPHDT,".") D
66 .I $P(NXTENDT,".")=$P(NXTPHDT,".") D
67 ..S NXTPHTM=$P(NXTPHDT,".",2),NXTENTM=$P(NXTENDT,".",2),PHENTM=$P(PHENRDT,".",2)
68 ..S NXTDIF=NXTENTM-NXTPHTM,PRVDIF=NXTPHTM-PHENTM
69 ..S:PRVDIF<NXTDIF PHREC=$O(^DPT(DFN,"PH","B",NXTPHDT,""))
70 .E S PHREC=$O(^DPT(DFN,"PH","B",NXTPHDT,""))
71 Q:'$D(PHREC)&('PRVPHDT) ""
72 S:'$D(PHREC) PHREC=$O(^DPT(DFN,"PH","B",PRVPHDT,""))
73 Q:'$D(PHREC) ""
74 S PHARY=$G(^DPT(DFN,"PH",PHREC,0))
75 S PHI=$$EXTERNAL^DILFD(2,.531,,$P(PHARY,U,2),.PHDIERR)
76 S PHST=$$EXTERNAL^DILFD(2,.532,,$P(PHARY,U,3),.PHDIERR)
77 S PHRR=$$EXTERNAL^DILFD(2,.533,,$P(PHARY,U,4),.PHDIERR)
78 Q PHI_"^"_PHST_"^"_PHRR
Note: See TracBrowser for help on using the repository browser.