- 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,1015**;Aug 13,1993;Build 21
- ;
- 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
- 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,1015**;Aug 13,1993;Build 21
- +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
