DGRP6EF ;ALB/TMK,EG,BAJ - REGISTRATION SCREEN 6 FIELDS FOR EXPOSURE FACTORS; 07/20/2006
;;5.3;PIMS;**689,659,737,1015,1016**;JUN 30, 2012;Build 20
;
EN(DFN,QUIT) ; Display Environmental exposure factors/allow to edit
N I,IND,DG321,DG322,DGCT,DIR,Z,X,Y,DIE,DR,DA,DGNONT
; Returns QUIT=1 if ^ entered
;
EN1 D CLEAR^VALM1
N DTOUT,DUOUT,TYPE,SEL,L,S,L1,L2,L3
S DG321=$G(^DPT(DFN,.321)),DG322=$G(^DPT(DFN,.322))
;
S DIR(0)="SA^",DGCT=0
S DGCT=DGCT+1,DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
S DGCT=DGCT+1,DIR("A",DGCT)="",$P(DIR("A",DGCT),"=",81)=""
S DGCT=DGCT+1,DIR("A",DGCT)=$J("",23)_"**** ENVIRONMENTAL FACTORS ****",DGCT=DGCT+1,DIR("A",DGCT)=" "
S IND=$S('$G(DGRPV):"[]",1:"<>")
S DGCT=DGCT+1
S Z=$E(IND)_"1"_$E(IND,2)
; "OTHER" choice added DG*5.3*688
; variables S,L1,L2, & L3 used for dynamic spacing
S SEL=$P(DG321,U,13),S=$C(32),($P(L1,S,6),$P(L2,S,$S(SEL="O":3,1:2)),$P(L3,S,3))=""
S TYPE=$S(SEL="K":" (DMZ) ",SEL="V":" (VIET)",SEL="O":" (OTH)",1:$J("",7))
S DIR("A",DGCT)=Z_L1_"A/O Exp.: "_$$YN^DGRP6CL(DG321,2)_TYPE_L2_"Reg: "_$$DAT^DGRP6CL(DG321,7,12)_L3_"Exam: "_$$DAT^DGRP6CL(DG321,9,12)_"A/O#: "_$P(DG321,U,10)
S Z=$E(IND)_"2"_$E(IND,2)
S DGCT=DGCT+1,DIR("A",DGCT)=Z_" ION Rad.: "_$$YN^DGRP6CL(DG321,3)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG321,11,12)_"Method: "
S:$P(DG321,U,12)>7 $P(DG321,U,12)="" S DIR("A",DGCT)=DIR("A",DGCT)_$P($T(SELTBL+$P(DG321,U,12)),";;",2)
S Z=$E(IND)_"3"_$E(IND,2)
;Env Contam name changed to SW Asia Conditions, DG*5.3*688
S DGCT=DGCT+1,DIR("A",DGCT)=Z_" SW Asia Cond: "_$$YN^DGRP6CL(DG322,13)_$J("",8)_"Reg: "_$$DAT^DGRP6CL(DG322,14,12)_" Exam: "_$$DAT^DGRP6CL(DG322,15,11)
S DGNONT=0 I $$GETSTAT^DGNTAPI1(DFN)>2,'$D(^XUSEC("DGNT VERIFY",DUZ)) S DGNONT=1
I $G(DGRPV) S DGNONT=1
S DGCT=DGCT+1,DIR("A",DGCT)=$S(DGNONT:"<",1:"[")_"4"_$S(DGNONT:">",1:"]")_" N/T Radium: " N DGNT S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT") S DIR("A",DGCT)=DIR("A",DGCT)_$G(DGNT("INTRP"))
;
S DGCT=DGCT+1,DIR("A",DGCT)=" "
S DIR("A")=$S('$G(DGRPV):"SELECT AN ENVIRONMENTAL FACTOR (1-"_(4-DGNONT)_") OR (Q)UIT: ",1:"PRESS RETURN TO CONTINUE ")
;Env Contam name changed to SW Asia Conditions, DG*5.3*688
S DIR(0)=$S('$G(DGRPV):"SA^1:A/O Exp;2:ION Rad;3:SW Asia Cond;"_$S(DGNONT:"",1:"4:N/T Radium;")_"Q:QUIT",1:"EA")
I '$G(DGRPV) S DIR("B")="QUIT"
D ^DIR K DIR
I $G(DGRPV)!$D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT
S Z="603"_$E("0",2-$L(+Y))_+Y
S DIE=2,DA=DFN,DR=$P($T(@Z),";;",2) D:DR'="" ^DIE
K DIE,DA,DR
G EN1
;
QUIT Q
;
EF(DFN,LIN) ;
N DG321,DG322,LENGTH,Z,SEQ
K LIN S (LENGTH,LIN)=0
S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322))
I $P(DG321,U,2)="Y" D
. S Z="A/O Exp.",SEQ=1
. ;S:'$P(DG321,U,7)!'$P(DG321,U,9)!($P(DG321,U,10)="") Z=Z_"(Incomplete)"
. S:'$P(DG321,U,7)!('$P(DG321,U,9))="" Z=Z_"(Incomplete)"
. D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
;
I $P(DG321,U,3)="Y" D
. S Z="Ion Rad.",SEQ=2
. S:'$P(DG321,U,11)!($P(DG321,U,12)="") Z=Z_"(Incomplete)"
. D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
;
I $P(DG322,U,13)="Y" D
. I 'LIN S LIN=LIN+1,LIN(LIN)=""
. ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
. S Z="SW Asia Cond.",SEQ=3
. S:'$P(DG322,U,14)!'$P(DG322,U,15) Z=Z_"(Incomplete)"
. D SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
; N/T Radium Exposure
N DGNT,DGRPX S DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT")
I "NO"'[$G(DGNT("INTRP")) D
. I 'LIN S LIN=LIN+1,LIN(LIN)=""
. S SEQ=4 D SETLNEX^DGRP6("N/T Radium ("_$P(DGNT("INTRP"),"YES,",2)_")",SEQ,.LIN,.LENGTH)
Q
; The following tag is a table of values. Do not change location of values including null at SELTBL+0
SELTBL ;;
;;NO VALUE
;;HIROSHIMA/NAGASAKI
;;ATMOSPHERIC NUCLEAR TEST
;;H/N AND ATMOSPHERIC TEST
;;UNDERGROUND NUCLEAR TEST
;;EXP. AT NUCLEAR FACILITY
;;OTHER
60301 ;;.32102//NO;S:X'="Y" Y="@65";.3213;.32107;.32109;.3211;@65;
60302 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66;
60303 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612;
60304 ;;D REG^DGNTQ(DFN)
;;
DGRP6EF ;ALB/TMK,EG,BAJ - REGISTRATION SCREEN 6 FIELDS FOR EXPOSURE FACTORS; 07/20/2006
+1 ;;5.3;PIMS;**689,659,737,1015,1016**;JUN 30, 2012;Build 20
+2 ;
EN(DFN,QUIT) ; Display Environmental exposure factors/allow to edit
+1 NEW I,IND,DG321,DG322,DGCT,DIR,Z,X,Y,DIE,DR,DA,DGNONT
+2 ; Returns QUIT=1 if ^ entered
+3 ;
EN1 DO CLEAR^VALM1
+1 NEW DTOUT,DUOUT,TYPE,SEL,L,S,L1,L2,L3
+2 SET DG321=$GET(^DPT(DFN,.321))
SET DG322=$GET(^DPT(DFN,.322))
+3 ;
+4 SET DIR(0)="SA^"
SET DGCT=0
+5 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
+6 SET DGCT=DGCT+1
SET DIR("A",DGCT)=""
SET $PIECE(DIR("A",DGCT),"=",81)=""
+7 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$JUSTIFY("",23)_"**** ENVIRONMENTAL FACTORS ****"
SET DGCT=DGCT+1
SET DIR("A",DGCT)=" "
+8 SET IND=$SELECT('$GET(DGRPV):"[]",1:"<>")
+9 SET DGCT=DGCT+1
+10 SET Z=$EXTRACT(IND)_"1"_$EXTRACT(IND,2)
+11 ; "OTHER" choice added DG*5.3*688
+12 ; variables S,L1,L2, & L3 used for dynamic spacing
+13 SET SEL=$PIECE(DG321,U,13)
SET S=$CHAR(32)
SET ($PIECE(L1,S,6),$PIECE(L2,S,$SELECT(SEL="O":3,1:2)),$PIECE(L3,S,3))=""
+14 SET TYPE=$SELECT(SEL="K":" (DMZ) ",SEL="V":" (VIET)",SEL="O":" (OTH)",1:$JUSTIFY("",7))
+15 SET DIR("A",DGCT)=Z_L1_"A/O Exp.: "_$$YN^DGRP6CL(DG321,2)_TYPE_L2_"Reg: "_$$DAT^DGRP6CL(DG321,7,12)_L3_"Exam: "_$$DAT^DGRP6CL(DG321,9,12)_"A/O#: "_$PIECE(DG321,U,10)
+16 SET Z=$EXTRACT(IND)_"2"_$EXTRACT(IND,2)
+17 SET DGCT=DGCT+1
SET DIR("A",DGCT)=Z_" ION Rad.: "_$$YN^DGRP6CL(DG321,3)_$JUSTIFY("",8)_"Reg: "_$$DAT^DGRP6CL(DG321,11,12)_"Method: "
+18 IF $PIECE(DG321,U,12)>7
SET $PIECE(DG321,U,12)=""
SET DIR("A",DGCT)=DIR("A",DGCT)_$PIECE($TEXT(SELTBL+$PIECE(DG321,U,12)),";;",2)
+19 SET Z=$EXTRACT(IND)_"3"_$EXTRACT(IND,2)
+20 ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
+21 SET DGCT=DGCT+1
SET DIR("A",DGCT)=Z_" SW Asia Cond: "_$$YN^DGRP6CL(DG322,13)_$JUSTIFY("",8)_"Reg: "_$$DAT^DGRP6CL(DG322,14,12)_" Exam: "_$$DAT^DGRP6CL(DG322,15,11)
+22 SET DGNONT=0
IF $$GETSTAT^DGNTAPI1(DFN)>2
IF '$DATA(^XUSEC("DGNT VERIFY",DUZ))
SET DGNONT=1
+23 IF $GET(DGRPV)
SET DGNONT=1
+24 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$SELECT(DGNONT:"<",1:"[")_"4"_$SELECT(DGNONT:">",1:"]")_" N/T Radium: "
NEW DGNT
SET DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT")
SET DIR("A",DGCT)=DIR("A",DGCT)_$GET(DGNT("INTRP"))
+25 ;
+26 SET DGCT=DGCT+1
SET DIR("A",DGCT)=" "
+27 SET DIR("A")=$SELECT('$GET(DGRPV):"SELECT AN ENVIRONMENTAL FACTOR (1-"_(4-DGNONT)_") OR (Q)UIT: ",1:"PRESS RETURN TO CONTINUE ")
+28 ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
+29 SET DIR(0)=$SELECT('$GET(DGRPV):"SA^1:A/O Exp;2:ION Rad;3:SW Asia Cond;"_$SELECT(DGNONT:"",1:"4:N/T Radium;")_"Q:QUIT",1:"EA")
+30 IF '$GET(DGRPV)
SET DIR("B")="QUIT"
+31 DO ^DIR
KILL DIR
+32 IF $GET(DGRPV)!$DATA(DUOUT)!$DATA(DTOUT)!(Y="Q")
IF Y'="Q"
SET QUIT=1
GOTO QUIT
+33 SET Z="603"_$EXTRACT("0",2-$LENGTH(+Y))_+Y
+34 SET DIE=2
SET DA=DFN
SET DR=$PIECE($TEXT(@Z),";;",2)
IF DR'=""
DO ^DIE
+35 KILL DIE,DA,DR
+36 GOTO EN1
+37 ;
QUIT QUIT
+1 ;
EF(DFN,LIN) ;
+1 NEW DG321,DG322,LENGTH,Z,SEQ
+2 KILL LIN
SET (LENGTH,LIN)=0
+3 SET DG321=$GET(^DPT(DFN,.321))
SET DG322=$GET(^(.322))
+4 IF $PIECE(DG321,U,2)="Y"
Begin DoDot:1
+5 SET Z="A/O Exp."
SET SEQ=1
+6 ;S:'$P(DG321,U,7)!'$P(DG321,U,9)!($P(DG321,U,10)="") Z=Z_"(Incomplete)"
+7 IF '$PIECE(DG321,U,7)!('$PIECE(DG321,U,9))=""
SET Z=Z_"(Incomplete)"
+8 DO SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
End DoDot:1
+9 ;
+10 IF $PIECE(DG321,U,3)="Y"
Begin DoDot:1
+11 SET Z="Ion Rad."
SET SEQ=2
+12 IF '$PIECE(DG321,U,11)!($PIECE(DG321,U,12)="")
SET Z=Z_"(Incomplete)"
+13 DO SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
End DoDot:1
+14 ;
+15 IF $PIECE(DG322,U,13)="Y"
Begin DoDot:1
+16 IF 'LIN
SET LIN=LIN+1
SET LIN(LIN)=""
+17 ;Env Contam name changed to SW Asia Conditions, DG*5.3*688
+18 SET Z="SW Asia Cond."
SET SEQ=3
+19 IF '$PIECE(DG322,U,14)!'$PIECE(DG322,U,15)
SET Z=Z_"(Incomplete)"
+20 DO SETLNEX^DGRP6(Z,SEQ,.LIN,.LENGTH)
End DoDot:1
+21 ; N/T Radium Exposure
+22 NEW DGNT,DGRPX
SET DGRPX=$$GETCUR^DGNTAPI(DFN,"DGNT")
+23 IF "NO"'[$GET(DGNT("INTRP"))
Begin DoDot:1
+24 IF 'LIN
SET LIN=LIN+1
SET LIN(LIN)=""
+25 SET SEQ=4
DO SETLNEX^DGRP6("N/T Radium ("_$PIECE(DGNT("INTRP"),"YES,",2)_")",SEQ,.LIN,.LENGTH)
End DoDot:1
+26 QUIT
+27 ; The following tag is a table of values. Do not change location of values including null at SELTBL+0
SELTBL ;;
+1 ;;NO VALUE
+2 ;;HIROSHIMA/NAGASAKI
+3 ;;ATMOSPHERIC NUCLEAR TEST
+4 ;;H/N AND ATMOSPHERIC TEST
+5 ;;UNDERGROUND NUCLEAR TEST
+6 ;;EXP. AT NUCLEAR FACILITY
+7 ;;OTHER
60301 ;;.32102//NO;S:X'="Y" Y="@65";.3213;.32107;.32109;.3211;@65;
60302 ;;.32103//NO;S:X'="Y" Y="@66";.3212;.32111;@66;
60303 ;;.322013//NO;S:X'="Y" Y="@612";.322014;Q;.322015;@612;
60304 ;;D REG^DGNTQ(DFN)
+1 ;;
