DGENL2 ;ALB/RMO - Patient Enrollment - Build List Area Cont.;16 JUN 1997 ; 7/8/05 1:37pm
;;5.3;Registration;**121,147,232,306,417,672**;Aug 13,1993
;
HIS(DGARY,DFN,DGENRIEN,DGLINE,DGCNT) ;Enrollment history
; Input -- DGARY Global array subscript
; DFN Patient IEN
; DGENRIEN Enrollment IEN
; DGLINE Line number
; Output -- DGCNT Number of lines in the list
N DGENR,DGNUM,DGPRIEN,DGSTART
;
S DGSTART=DGLINE ;starting line number
S DGNUM=0 ;selection number
D SET(DGARY,DGLINE,"Enrollment History",31,IORVON,IORVOFF,,,,.DGCNT)
;
;Enrollment date, status, priority, date/time entered
S DGLINE=DGLINE+1
D SET(DGARY,DGLINE," Effective Date Status Priority Date/Time Entered",5,,,,,,.DGCNT)
S DGLINE=DGLINE+1
D SET(DGARY,DGLINE,"===============================================================================",1,,,,,,.DGCNT)
S DGPRIEN=DGENRIEN
F S DGPRIEN=$$FINDPRI^DGENA(DGPRIEN) Q:'DGPRIEN D
. I $$GET^DGENA(DGPRIEN,.DGENR) D
. . S DGNUM=DGNUM+1
. . S DGLINE=DGLINE+1
. . D SET(DGARY,DGLINE,DGNUM,1,,,"EH",DGNUM,DGPRIEN,.DGCNT)
. . D SET(DGARY,DGLINE,$S($G(DGENR("EFFDATE")):$$EXT^DGENU("EFFDATE",DGENR("EFFDATE")),1:""),5,,,,,,.DGCNT)
. . D SET(DGARY,DGLINE,$S($G(DGENR("STATUS")):$E($$EXT^DGENU("STATUS",DGENR("STATUS")),1,19),1:""),25,,,,,,.DGCNT)
. . D SET(DGARY,DGLINE,$S($G(DGENR("PRIORITY")):DGENR("PRIORITY")_$$EXTERNAL^DILFD(27.11,.12,"F",$G(DGENR("SUBGRP"))),1:""),45,,,,,,.DGCNT)
. . D SET(DGARY,DGLINE,$S($G(DGENR("DATETIME")):$$EXT^DGENU("DATETIME",DGENR("DATETIME")),1:""),57,,,,,,.DGCNT)
Q
;this SET subroutine is being moved to DGENL2 from DGENL1, which has
;gotten too big. patch DG*5.3*653
SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,DGCNT) ; -- set display array
; Input -- DGARY Global array subscript
; DGLINE Line number
; DGTEXT Text
; DGCOL Column to start at (optional)
; DGON Highlighting on (optional)
; DGOFF Highlighting off (optional)
; DGSUB Secondary list subscript (optional)
; DGNUM Selection number (optional)
; DGDATA Data associated with selection (optional)
; Output -- DGCNT Number of lines in the list
N X
S:DGLINE>DGCNT DGCNT=DGLINE
S X=$S($D(^TMP(DGARY,$J,DGLINE,0)):^(0),1:"")
S ^TMP(DGARY,$J,DGLINE,0)=$$SETSTR^VALM1(DGTEXT,X,DGCOL,$L(DGTEXT))
D:$G(DGON)]""!($G(DGOFF)]"") CNTRL^VALM10(DGLINE,DGCOL,$L(DGTEXT),$G(DGON),$G(DGOFF))
;Set-up special index for secondary selection list
S:$G(DGSUB)]"" ^TMP(DGARY_"IDX",$J,DGSUB,DGNUM,DGLINE)=DGDATA,^TMP(DGARY_"IDX",$J,DGSUB,0)=DGNUM
Q
PHEART(DFN,DGENRIEN,PHENRDT) ;find Purple Heart information based on enrollment date
N NXTENR,NXTENDT,PRVENR,PRVENDT,PHARY,PHI,PHST,PHRR,PHDIERR
N NXTDIF,NXTENTM,NXTPHDT,NXTPHTM,PHENTM,PHREC,PRVDIF,PRVPHDT
S U="^",(PRVDIF,NXTDIF)=""
Q:'(PHENRDT&DGENRIEN) ""
S PRVENDT=0,NXTENDT=9999999
S PRVENR=$O(^DGEN(27.11,"C",DFN,DGENRIEN),-1)
S:PRVENR PRVENDT=$P($G(^DGEN(27.11,PRVENR,"U")),U)
S PRVPHDT=$O(^DPT(DFN,"PH","B",PHENRDT),-1)
S NXTENR=$O(^DGEN(27.11,"C",DFN,DGENRIEN))
S:NXTENR NXTENDT=$P($G(^DGEN(27.11,NXTENR,"U")),U)
S NXTPHDT=$O(^DPT(DFN,"PH","B",PHENRDT-.0000001))
I NXTPHDT<NXTENDT,$P(PHENRDT,".")=$P(NXTPHDT,".") D
.I $P(NXTENDT,".")=$P(NXTPHDT,".") D
..S NXTPHTM=$P(NXTPHDT,".",2),NXTENTM=$P(NXTENDT,".",2),PHENTM=$P(PHENRDT,".",2)
..S NXTDIF=NXTENTM-NXTPHTM,PRVDIF=NXTPHTM-PHENTM
..S:PRVDIF<NXTDIF PHREC=$O(^DPT(DFN,"PH","B",NXTPHDT,""))
.E S PHREC=$O(^DPT(DFN,"PH","B",NXTPHDT,""))
Q:'$D(PHREC)&('PRVPHDT) ""
S:'$D(PHREC) PHREC=$O(^DPT(DFN,"PH","B",PRVPHDT,""))
Q:'$D(PHREC) ""
S PHARY=$G(^DPT(DFN,"PH",PHREC,0))
S PHI=$$EXTERNAL^DILFD(2,.531,,$P(PHARY,U,2),.PHDIERR)
S PHST=$$EXTERNAL^DILFD(2,.532,,$P(PHARY,U,3),.PHDIERR)
S PHRR=$$EXTERNAL^DILFD(2,.533,,$P(PHARY,U,4),.PHDIERR)
Q PHI_"^"_PHST_"^"_PHRR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENL2 4052 printed Nov 22, 2024@17:52:45 Page 2
DGENL2 ;ALB/RMO - Patient Enrollment - Build List Area Cont.;16 JUN 1997 ; 7/8/05 1:37pm
+1 ;;5.3;Registration;**121,147,232,306,417,672**;Aug 13,1993
+2 ;
HIS(DGARY,DFN,DGENRIEN,DGLINE,DGCNT) ;Enrollment history
+1 ; Input -- DGARY Global array subscript
+2 ; DFN Patient IEN
+3 ; DGENRIEN Enrollment IEN
+4 ; DGLINE Line number
+5 ; Output -- DGCNT Number of lines in the list
+6 NEW DGENR,DGNUM,DGPRIEN,DGSTART
+7 ;
+8 ;starting line number
SET DGSTART=DGLINE
+9 ;selection number
SET DGNUM=0
+10 DO SET(DGARY,DGLINE,"Enrollment History",31,IORVON,IORVOFF,,,,.DGCNT)
+11 ;
+12 ;Enrollment date, status, priority, date/time entered
+13 SET DGLINE=DGLINE+1
+14 DO SET(DGARY,DGLINE," Effective Date Status Priority Date/Time Entered",5,,,,,,.DGCNT)
+15 SET DGLINE=DGLINE+1
+16 DO SET(DGARY,DGLINE,"===============================================================================",1,,,,,,.DGCNT)
+17 SET DGPRIEN=DGENRIEN
+18 FOR
SET DGPRIEN=$$FINDPRI^DGENA(DGPRIEN)
if 'DGPRIEN
QUIT
Begin DoDot:1
+19 IF $$GET^DGENA(DGPRIEN,.DGENR)
Begin DoDot:2
+20 SET DGNUM=DGNUM+1
+21 SET DGLINE=DGLINE+1
+22 DO SET(DGARY,DGLINE,DGNUM,1,,,"EH",DGNUM,DGPRIEN,.DGCNT)
+23 DO SET(DGARY,DGLINE,$SELECT($GET(DGENR("EFFDATE")):$$EXT^DGENU("EFFDATE",DGENR("EFFDATE")),1:""),5,,,,,,.DGCNT)
+24 DO SET(DGARY,DGLINE,$SELECT($GET(DGENR("STATUS")):$EXTRACT($$EXT^DGENU("STATUS",DGENR("STATUS")),1,19),1:""),25,,,,,,.DGCNT)
+25 DO SET(DGARY,DGLINE,$SELECT($GET(DGENR("PRIORITY")):DGENR("PRIORITY")_$$EXTERNAL^DILFD(27.11,.12,"F",$GET(DGENR("SUBGRP"))),1:""),45,,,,,,.DGCNT)
+26 DO SET(DGARY,DGLINE,$SELECT($GET(DGENR("DATETIME")):$$EXT^DGENU("DATETIME",DGENR("DATETIME")),1:""),57,,,,,,.DGCNT)
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;this SET subroutine is being moved to DGENL2 from DGENL1, which has
+29 ;gotten too big. patch DG*5.3*653
SET(DGARY,DGLINE,DGTEXT,DGCOL,DGON,DGOFF,DGSUB,DGNUM,DGDATA,DGCNT) ; -- set display array
+1 ; Input -- DGARY Global array subscript
+2 ; DGLINE Line number
+3 ; DGTEXT Text
+4 ; DGCOL Column to start at (optional)
+5 ; DGON Highlighting on (optional)
+6 ; DGOFF Highlighting off (optional)
+7 ; DGSUB Secondary list subscript (optional)
+8 ; DGNUM Selection number (optional)
+9 ; DGDATA Data associated with selection (optional)
+10 ; Output -- DGCNT Number of lines in the list
+11 NEW X
+12 if DGLINE>DGCNT
SET DGCNT=DGLINE
+13 SET X=$SELECT($DATA(^TMP(DGARY,$JOB,DGLINE,0)):^(0),1:"")
+14 SET ^TMP(DGARY,$JOB,DGLINE,0)=$$SETSTR^VALM1(DGTEXT,X,DGCOL,$LENGTH(DGTEXT))
+15 if $GET(DGON)]""!($GET(DGOFF)]"")
DO CNTRL^VALM10(DGLINE,DGCOL,$LENGTH(DGTEXT),$GET(DGON),$GET(DGOFF))
+16 ;Set-up special index for secondary selection list
+17 if $GET(DGSUB)]""
SET ^TMP(DGARY_"IDX",$JOB,DGSUB,DGNUM,DGLINE)=DGDATA
SET ^TMP(DGARY_"IDX",$JOB,DGSUB,0)=DGNUM
+18 QUIT
PHEART(DFN,DGENRIEN,PHENRDT) ;find Purple Heart information based on enrollment date
+1 NEW NXTENR,NXTENDT,PRVENR,PRVENDT,PHARY,PHI,PHST,PHRR,PHDIERR
+2 NEW NXTDIF,NXTENTM,NXTPHDT,NXTPHTM,PHENTM,PHREC,PRVDIF,PRVPHDT
+3 SET U="^"
SET (PRVDIF,NXTDIF)=""
+4 if '(PHENRDT&DGENRIEN)
QUIT ""
+5 SET PRVENDT=0
SET NXTENDT=9999999
+6 SET PRVENR=$ORDER(^DGEN(27.11,"C",DFN,DGENRIEN),-1)
+7 if PRVENR
SET PRVENDT=$PIECE($GET(^DGEN(27.11,PRVENR,"U")),U)
+8 SET PRVPHDT=$ORDER(^DPT(DFN,"PH","B",PHENRDT),-1)
+9 SET NXTENR=$ORDER(^DGEN(27.11,"C",DFN,DGENRIEN))
+10 if NXTENR
SET NXTENDT=$PIECE($GET(^DGEN(27.11,NXTENR,"U")),U)
+11 SET NXTPHDT=$ORDER(^DPT(DFN,"PH","B",PHENRDT-.0000001))
+12 IF NXTPHDT<NXTENDT
IF $PIECE(PHENRDT,".")=$PIECE(NXTPHDT,".")
Begin DoDot:1
+13 IF $PIECE(NXTENDT,".")=$PIECE(NXTPHDT,".")
Begin DoDot:2
+14 SET NXTPHTM=$PIECE(NXTPHDT,".",2)
SET NXTENTM=$PIECE(NXTENDT,".",2)
SET PHENTM=$PIECE(PHENRDT,".",2)
+15 SET NXTDIF=NXTENTM-NXTPHTM
SET PRVDIF=NXTPHTM-PHENTM
+16 if PRVDIF<NXTDIF
SET PHREC=$ORDER(^DPT(DFN,"PH","B",NXTPHDT,""))
End DoDot:2
+17 IF '$TEST
SET PHREC=$ORDER(^DPT(DFN,"PH","B",NXTPHDT,""))
End DoDot:1
+18 if '$DATA(PHREC)&('PRVPHDT)
QUIT ""
+19 if '$DATA(PHREC)
SET PHREC=$ORDER(^DPT(DFN,"PH","B",PRVPHDT,""))
+20 if '$DATA(PHREC)
QUIT ""
+21 SET PHARY=$GET(^DPT(DFN,"PH",PHREC,0))
+22 SET PHI=$$EXTERNAL^DILFD(2,.531,,$PIECE(PHARY,U,2),.PHDIERR)
+23 SET PHST=$$EXTERNAL^DILFD(2,.532,,$PIECE(PHARY,U,3),.PHDIERR)
+24 SET PHRR=$$EXTERNAL^DILFD(2,.533,,$PIECE(PHARY,U,4),.PHDIERR)
+25 QUIT PHI_"^"_PHST_"^"_PHRR
