| [613] | 1 | DGENL2 ;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 | ;
|
|---|
| 4 | HIS(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
|
|---|
| 34 | SET(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
|
|---|
| 53 | PHEART(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
|
|---|
