DGRP6CL ;ALB/TMK,LBD - REGISTRATION SCREEN 6 FIELDS Conflict locations ; 6/23/09 4:08pm
;;5.3;PIMS;**689,751,1015,1016**;JUN 30, 2012;Build 20
;
CLLST(DFN,DGCONF,DGPOSS,DGMSE) ;
; For patient DFN:
; Returns DGCONF array: DGCONF(conf loc)= Start dt^End dt
; or, for multiple OEF/OIF/ UNKNOWN OEF/OIF: DGCONF(conf loc-ien) =
; Start dt ^ End dt ^ Site source ^ Lock flag
; DGCONF(conflict loc,1)=1 if dts inconsistent w/mse dts
; DGPOSS = array of possible conflict locations, based on service
; episode dts DGPOSS(conf loc)=""
; DGMSE = array of military svc episodes
; DGMSE(1-n)=fr dt^to dt^branch ien^comp code
;
N DGZ,DGZ0,DIQUIET,FRTO
S DIQUIET=1 K DGCONF,DGPOSS
; Get Military Service Episodes and store in DGMSE array (DG*5.3*797)
D GETMSE
;
; Must chk all possible/on-file conf locs for valid mil svc pd
; Extract OEF/OIF data
F DGZ="OEF","OIF","UNK" S DGCONF(DGZ)=""
D GET^DGENOEIF(DFN,.DGZ,0,"","")
S DGZ0=0 F S DGZ0=$O(DGZ("IEN",DGZ0)) Q:'DGZ0 S DGZ=$G(DGZ("IEN",DGZ0)) D
. N DGCONFX
. Q:'$G(DGZ("FR",DGZ0))&'$G(DGZ("TO",DGZ0))
. S DGCONFX=$P("OIF^OEF^UNK",U,+$G(DGZ("LOC",DGZ0)))_"-"_DGZ,DGCONF=DGCONFX,DGCONF($P(DGCONFX,"-"))=$G(DGCONF($P(DGCONFX,"-")))_DGZ_";"
. F FRTO=1,0 S $P(DGCONF(DGCONFX),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONFX,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
. S $P(DGCONF(DGCONFX),U,3)=$G(DGZ("SITE",DGZ0))
. S $P(DGCONF(DGCONFX),U,4)=$G(DGZ("LOCK",DGZ0))
F DGCONF="OEF","OIF","UNK" D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
F DGCONF="VIET","LEB","GREN","PAN","GULF","SOM","YUG" F FRTO=1,0 S $P(DGCONF(DGCONF),U,$S(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONF,FRTO) I FRTO=0 D CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
Q
;
GETMSE ;Get Military Service Data and store in DGMSE array (DG*5.3*797)
;DGMSE(1-3)=fr dt^to dt^branch ien^comp code
;Get MSE data from MSE sub-file #2.3216, if it's populated
N MSE,DGZ,DGZ0,DGZ1,DG32,DG3291
I $D(^DPT(DFN,.3216)) D Q
. D GETMSE^DGMSEUTL(DFN,.MSE)
. S (MSE,DGZ)=0
. F S MSE=$O(MSE(MSE)) Q:'MSE S DGZ=DGZ+1,DGMSE(DGZ)=$P(MSE(MSE),U,1,4)
;Else get MSE data from .32 and .3291 nodes of Patient file #2
S DG32=$G(^DPT(DFN,.32)),DG3291=$G(^(.3291))
S DGZ1=0
F DGZ=1:1:3 S DGZ0=$S(DGZ=1:"5^5^6^7",DGZ=2:"19^10^11^12",1:"20^15^16^17") D
. Q:$S($P(DG32,U,+DGZ0)="Y":0,1:'$P(DG32,U,+DGZ0))
. S DGZ1=DGZ1+1,DGMSE(DGZ1)=$P(DG32,U,$P(DGZ0,U,3))_U_$P(DG32,U,$P(DGZ0,U,4))_U_$P(DG32,U,$P(DGZ0,U,2))_U_$P(DG3291,U,DGZ)
Q
;
YN(DGRPX,X) ;Format Yes/No fld in $P(DGRPX,U,X)
Q $S($P(DGRPX,"^",X)="Y":"YES",$P(DGRPX,"^",X)="N":"NO ",$P(DGRPX,"^",X)="U":"UNK",1:" ")
;
DAT(DGRPX,X,Z1) ; Format dt in $P(DGRPX,U,X) for a length of Z1
N Z
S Z=$P(DGRPX,U,X)
I Z'="" S Z=$$FMTE^XLFDT(Z,"5DZ")
S:$L(Z)<Z1 Z=$E(Z_$J("",Z1),1,Z1)
Q Z
;
EN(DFN,QUIT) ; Entry from reg screen 6
N DIPA,DGCONF,DGCONFS,DGCONF1,DGMSE,DGMSG,DGPOSS,DIR,DIE,DR,DA
;
; Return QUIT=1 if ^ entered
EN1 ; Entry from conf subscreen off reg screen 6
; Routine loops until exit/quit from subscreen
D CLEAR^VALM1
K DGCONF,DGCONFS,DGPOSS,DGMSE,DGMSG,DGDISP
N DIR,DTOUT,DUOUT,Z,Z0,Z1,Z2,X,Y,LOOP,DG,DGM,DGZ,DGEG,DGEGS,DGX,DGX1,DG321,DG322,DGCT,DGY,DGY1,DGCTX,SSN
D CLLST(DFN,.DGCONF,.DGPOSS,.DGMSE)
I $G(DGRPV) S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
I '$G(DGRPV),$E(DGRPVV(6),2,3)="11" S $E(DGRPVV(6),2,3)="00",DGRPVV(6,"NOEDIT")=1
S DGMSG=0,DGCTX=0
F Z="OEF","OIF","UNK" D ; Sort OEF/OIF/ UNKNOWN OEF/OIF
. ; by reverse from dt within each conf
. S Z0=Z F S Z0=$O(DGCONF(Z0)) Q:Z0=""!(Z0'[Z) S Z2=Z_"-"_(9999999-DGCONF(Z0)) S DGCONFS(Z2)=$P(Z0,"-",2) I 'DGMSG,$G(DGCONF(Z0,1)) S DGMSG=1
S DG321=$G(^DPT(DFN,.321)),DG322=$G(^(.322))
;
S DIR(0)="SA^",DGCT=0
S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
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)=$S($O(DGMSE(0)):"MILITARY SERVICE PERIODS:",1:"NO SERVICE PERIODS FOR THIS PATIENT - NO CONFLICT LOC CAN BE ENTERED")
S Z=0 F S Z=$O(DGMSE(Z)) Q:'Z!(Z>4) D
. I Z=4 S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_"<more episodes>" Q
. S DGCT=DGCT+1,DIR("A",DGCT)=$J("",3)_$E($$EXTERNAL^DILFD(2,.325,"",$P(DGMSE(Z),U,3))_$S($P(DGMSE(Z),U,4)'="":"/"_$$SVCCOMP($P(DGMSE(Z),U,4)),1:"")_$J("",30),1,30)
. S DIR("A",DGCT)=DIR("A",DGCT)_" ("_$S($P(DGMSE(Z),U):$$FMTE^XLFDT($P(DGMSE(Z),U),"5DZ"),1:"missing")_"-"_$S($P(DGMSE(Z),U,2):$$FMTE^XLFDT($P(DGMSE(Z),U,2),"5DZ"),1:"missing")_")"
S DGCT=DGCT+1,DIR("A",DGCT)=" "
S DGCT=DGCT+1,DIR("A",DGCT)=$J("",24)_"---- CONFLICT LOCATIONS ----"
S DGCT=DGCT+1,DIR("A",DGCT)=$J("",34)_"FROM"_$J("",9)_"TO"_$J("",7)_"SOURCE (FOR OEF/OIF)"
; DGCONF(DGCONF,"OK")=# entries for OEF/OIF/ UNKNOWN OEF/OIF
; that are site-entered
; DGCONF(DGCONF,"OK",entry ien)=display #^formatted from dt^
; formatted to dt^inconsistent flag (valid entries for editing)
S DGEG=0
F DGEGS=2,1,3 D
. S DGCONF=$P("OIF^OEF^UNK",U,DGEGS),DGM=0
. S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
. S DGEG=DGEG+1
. S DGDISP=$S(DGCONF'="UNK":$J("",8),1:"OEF/OIF ")_DGCONF_": "
. S DGCT=DGCT+1,DGCTX=DGCT S DIR("A",DGCT)=" "_$E(DG,1)_DGEG_$E(DG,2)_" -"_DGDISP_$$YN($S(DGCONF(DGCONF):"Y",'$D(^DPT(DFN,.3215,0)):"",1:"N"),1)
. I $G(DGCONF(DGCONF))!$D(DGPOSS(DGCONF)) I '$G(DGRPV),$G(DGCONF(DGCONF,"VEDIT"))'=2,'$G(DGCONF(DGCONF,"NOEDIT")) S:DGCONF'="UNK" DIR(0)=DIR(0)_DGEG_":"_DGCONF_";"
. S (DGZ,DGCONFS)=DGCONF F S DGCONFS=$O(DGCONFS(DGCONFS)) Q:DGCONFS=""!(DGCONFS'[DGZ) D
.. N DGUN,DGIEN,STA
.. S DGIEN=DGCONFS(DGCONFS),DGCONF=DGZ_"-"_DGIEN,DGCONF1=DGZ,DGM=DGM+1
.. I $G(DGCONF(DGCONF,1)),DGCTX S $E(DIR("A",DGCTX),1,3)="***"
.. S DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
.. S DGUN=$S($G(DGCONF(DGCONF,"NOEDIT")):1,1:0)
.. I 'DGUN S DGCONF(DGCONF1,"OK")=$G(DGCONF(DGCONF1,"OK"))+1,DGCONF(DGCONF1,"OK",DGIEN)=DGM_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U),"5DZ")_U_$$FMTE^XLFDT($P(DGCONF(DGCONF),U,2),"5DZ")
.. I DGM>1 S DGCT=DGCT+1
.. S DIR("A",DGCT)=$S(DGM>1:$J("",27-$L(DGM)),1:DIR("A",DGCT)_" ")_"("_DGM_") "_$E($$DAT(DGCONF(DGCONF),1,13)_$J("",12),1,12)_$E($$DAT(DGCONF(DGCONF),2,11)_$J("",10),1,10)_" "
.. S STA=$P(DGCONF(DGCONF),U,3)
.. S:STA STA=$P($G(^DIC(4,+STA,99)),U)
.. S DIR("A",DGCT)=DIR("A",DGCT)_$S($P(DGCONF(DGCONF),U,3)="CEV":"",1:"Station #")_$E(STA_$J("",$S('DGUN:6,1:3)),1,$S('DGUN:6,1:3))
.. I DGUN S DIR("A",DGCT)=DIR("A",DGCT)_" (No Edit)"
D LOOPCNF^DGRP6CL1(.DGCONF,.DGPOSS,.DIR)
S DGCT=DGCT+1,DIR("A",DGCT)=" "
I $G(DGMSG) S DGCT=DGCT+1,DIR("A",DGCT)="*** ==>OEF/OIF Dates are inconsistent with veteran's military service episodes"
S DIR("A")="SELECT THE NUMBER OF A CONFLICT LOCATION OR (Q)UIT: "
S DIR(0)=DIR(0)_"Q:QUIT"
S DIR("?")="^D HELP^DGRP6CL1($P(DIR(0),U,2))"
S DIR("B")="QUIT"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT)!(Y="Q") S:Y'="Q" QUIT=1 G QUIT
S DGY=Y,DGY1=$S(Y=2:1,Y=1:2,1:Y)
I DGY<4 S DGCONF=""
I DGY'<4 D
. S DGCONF=$P("OEF^OIF^UNK^VIET^LEB^GREN^PAN^GULF^SOM^YUG",U,DGY)
. I $G(DGCONF(DGCONF,1)) W !!,"WARNING - THIS CONFLICT IS INCONSISTENT WITH MILITARY SERVICE DATA",!
. S DIE=2,DA=DFN,DR=$P($T(@DGCONF),";;",2) D:DR'="" ^DIE K DIE,DA,DR
I DGY=1!(DGY=2) D
. S DGCONF=$P("OEF^OIF",U,DGY)
. I '$G(DGCONF(DGCONF,"OK")),$G(DGCONF(DGCONF,"VEDIT"))'=2 D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q ; Add new only valid action
. I $G(DGCONF(DGCONF,"VEDIT"))=1 S DIR("A")="DO YOU WANT TO (A)DD OR (E)DIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="SA^A:ADD;E:EDIT",DIR("B")="ADD" D ^DIR K DIR
. I $G(DGCONF(DGCONF,"VEDIT"))=2,$G(DGCONF(DGCONF,"OK")) S DIR("A")="DO YOU WANT TO EDIT "_DGCONF_" CONFLICT DATA?: ",DIR(0)="YA",DIR("B")="YES" D ^DIR K DIR S Y=$S(Y=1:"E",1:Y)
. Q:$D(DTOUT)!$D(DUOUT)
. I Y="A" D ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF) Q
. I Y="E" D
.. N DGXREF,IEN,DIR,X,Y
.. I DGCONF(DGCONF,"OK")=1 S IEN=+$O(DGCONF(DGCONF,"OK",0)) I IEN D EDCFL^DGRP6CL1(DFN,IEN,$G(DGCONF(DGCONF,"VEDIT"))) Q
.. S DIR(0)="SA^",DIR("A")="SELECT THE # OF THE "_DGCONF_" CONFLICT PERIOD TO EDIT: ",DIR("A",1)=" "
.. S Z=0 F S Z=$O(DGCONF(DGCONF,"OK",Z)) Q:'Z S Z0=DGCONF(DGCONF,"OK",Z),DIR(0)=DIR(0)_+Z0_":"_$P(Z0,U,2)_$S($P(Z0,U,3)'="":"-"_$P(Z0,U,3),1:"")_";",DGXREF(+Z0)=Z
.. S DIR(0)=DIR(0)_"Q:QUIT"
.. D ^DIR K DIR
.. I Y D EDCFL^DGRP6CL1(DFN,+$G(DGXREF(+Y)),$G(DGCONF(DGCONF,"VEDIT")))
G EN1
;
QUIT Q
;
EN2 ; Consistency checker re-edit entrypoint for OEF/OIF data
N DGOEIF,DGZ,DGQUIT,Z,Z0,Y
D GET^DGENOEIF(DFN,.DGOEIF,2,"",1)
I $G(DGOEIF("COUNT"))&($O(DGOEIF("OIF",0))!$O(DGOEIF("OEF",0))) D
. F Z="OEF","OIF" S Z0=0 F S Z0=$O(DGOEIF(Z,Z0)) Q:'Z0 I $G(DGOEIF(Z,Z0,"IEN")) S DGZ(DGOEIF(Z,Z0,"IEN"))=""
. S (DGQUIT,DGZ)=0 F S DGZ=$O(DGZ(DGZ)) Q:'DGZ D Q:DGQUIT
.. N DGX,DA,DIE,DR,X
.. S DGX=$G(^DPT(DFN,.3215,DGZ,0))
.. W !!,"OEF/OIF CONFLICT: ",$$EXTERNAL^DILFD(2.3215,.01,"",$P(DGX,U))," FROM: "_$$EXTERNAL^DILFD(2.3215,.02,"",$P(DGX,U,2))," TO: "_$$EXTERNAL^DILFD(2.3215,.03,"",$P(DGX,U,3))
.. S DA=DGZ,DA(1)=DFN,DIE="^DPT("_DA(1)_",.3215,",DR=".01;.02R;.03R" D ^DIE I $D(Y) S DGQUIT=1
Q
;
SVCCOMP(X) ; Returns display text for service component
Q $S(X="R":"REGULAR",X="V":"RESERVE",X="G":"GUARD",1:"")
;
VIET ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64;
LEB ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67;
GREN ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68;
PAN ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69;
GULF ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610;
SOM ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611;
YUG ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615;
OEF ;;
OIF ;;
UNK ;;
;;
DGRP6CL ;ALB/TMK,LBD - REGISTRATION SCREEN 6 FIELDS Conflict locations ; 6/23/09 4:08pm
+1 ;;5.3;PIMS;**689,751,1015,1016**;JUN 30, 2012;Build 20
+2 ;
CLLST(DFN,DGCONF,DGPOSS,DGMSE) ;
+1 ; For patient DFN:
+2 ; Returns DGCONF array: DGCONF(conf loc)= Start dt^End dt
+3 ; or, for multiple OEF/OIF/ UNKNOWN OEF/OIF: DGCONF(conf loc-ien) =
+4 ; Start dt ^ End dt ^ Site source ^ Lock flag
+5 ; DGCONF(conflict loc,1)=1 if dts inconsistent w/mse dts
+6 ; DGPOSS = array of possible conflict locations, based on service
+7 ; episode dts DGPOSS(conf loc)=""
+8 ; DGMSE = array of military svc episodes
+9 ; DGMSE(1-n)=fr dt^to dt^branch ien^comp code
+10 ;
+11 NEW DGZ,DGZ0,DIQUIET,FRTO
+12 SET DIQUIET=1
KILL DGCONF,DGPOSS
+13 ; Get Military Service Episodes and store in DGMSE array (DG*5.3*797)
+14 DO GETMSE
+15 ;
+16 ; Must chk all possible/on-file conf locs for valid mil svc pd
+17 ; Extract OEF/OIF data
+18 FOR DGZ="OEF","OIF","UNK"
SET DGCONF(DGZ)=""
+19 DO GET^DGENOEIF(DFN,.DGZ,0,"","")
+20 SET DGZ0=0
FOR
SET DGZ0=$ORDER(DGZ("IEN",DGZ0))
IF 'DGZ0
QUIT
SET DGZ=$GET(DGZ("IEN",DGZ0))
Begin DoDot:1
+21 NEW DGCONFX
+22 IF '$GET(DGZ("FR",DGZ0))&'$GET(DGZ("TO",DGZ0))
QUIT
+23 SET DGCONFX=$PIECE("OIF^OEF^UNK",U,+$GET(DGZ("LOC",DGZ0)))_"-"_DGZ
SET DGCONF=DGCONFX
SET DGCONF($PIECE(DGCONFX,"-"))=$GET(DGCONF($PIECE(DGCONFX,"-")))_DGZ_";"
+24 FOR FRTO=1,0
SET $PIECE(DGCONF(DGCONFX),U,$SELECT(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONFX,FRTO)
IF FRTO=0
DO CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
+25 SET $PIECE(DGCONF(DGCONFX),U,3)=$GET(DGZ("SITE",DGZ0))
+26 SET $PIECE(DGCONF(DGCONFX),U,4)=$GET(DGZ("LOCK",DGZ0))
End DoDot:1
+27 FOR DGCONF="OEF","OIF","UNK"
DO CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
+28 FOR DGCONF="VIET","LEB","GREN","PAN","GULF","SOM","YUG"
FOR FRTO=1,0
SET $PIECE(DGCONF(DGCONF),U,$SELECT(FRTO:1,1:2))=$$GETDT^DGRPMS(DFN,DGCONF,FRTO)
IF FRTO=0
DO CKDT^DGRP6CL1(.DGCONF,.DGMSE,.DGPOSS)
+29 QUIT
+30 ;
GETMSE ;Get Military Service Data and store in DGMSE array (DG*5.3*797)
+1 ;DGMSE(1-3)=fr dt^to dt^branch ien^comp code
+2 ;Get MSE data from MSE sub-file #2.3216, if it's populated
+3 NEW MSE,DGZ,DGZ0,DGZ1,DG32,DG3291
+4 IF $DATA(^DPT(DFN,.3216))
Begin DoDot:1
+5 DO GETMSE^DGMSEUTL(DFN,.MSE)
+6 SET (MSE,DGZ)=0
+7 FOR
SET MSE=$ORDER(MSE(MSE))
IF 'MSE
QUIT
SET DGZ=DGZ+1
SET DGMSE(DGZ)=$PIECE(MSE(MSE),U,1,4)
End DoDot:1
QUIT
+8 ;Else get MSE data from .32 and .3291 nodes of Patient file #2
+9 SET DG32=$GET(^DPT(DFN,.32))
SET DG3291=$GET(^(.3291))
+10 SET DGZ1=0
+11 FOR DGZ=1:1:3
SET DGZ0=$SELECT(DGZ=1:"5^5^6^7",DGZ=2:"19^10^11^12",1:"20^15^16^17")
Begin DoDot:1
+12 IF $SELECT($PIECE(DG32,U,+DGZ0)="Y"
QUIT
+13 SET DGZ1=DGZ1+1
SET DGMSE(DGZ1)=$PIECE(DG32,U,$PIECE(DGZ0,U,3))_U_$PIECE(DG32,U,$PIECE(DGZ0,U,4))_U_$PIECE(DG32,U,$PIECE(DGZ0,U,2))_U_$PIECE(DG3291,U,DGZ)
End DoDot:1
+14 QUIT
+15 ;
YN(DGRPX,X) ;Format Yes/No fld in $P(DGRPX,U,X)
+1 QUIT $SELECT($PIECE(DGRPX,"^",X)="Y":"YES",$PIECE(DGRPX,"^",X)="N":"NO ",$PIECE(DGRPX,"^",X)="U":"UNK",1:" ")
+2 ;
DAT(DGRPX,X,Z1) ; Format dt in $P(DGRPX,U,X) for a length of Z1
+1 NEW Z
+2 SET Z=$PIECE(DGRPX,U,X)
+3 IF Z'=""
SET Z=$$FMTE^XLFDT(Z,"5DZ")
+4 IF $LENGTH(Z)<Z1
SET Z=$EXTRACT(Z_$JUSTIFY("",Z1),1,Z1)
+5 QUIT Z
+6 ;
EN(DFN,QUIT) ; Entry from reg screen 6
+1 NEW DIPA,DGCONF,DGCONFS,DGCONF1,DGMSE,DGMSG,DGPOSS,DIR,DIE,DR,DA
+2 ;
+3 ; Return QUIT=1 if ^ entered
EN1 ; Entry from conf subscreen off reg screen 6
+1 ; Routine loops until exit/quit from subscreen
+2 DO CLEAR^VALM1
+3 KILL DGCONF,DGCONFS,DGPOSS,DGMSE,DGMSG,DGDISP
+4 NEW DIR,DTOUT,DUOUT,Z,Z0,Z1,Z2,X,Y,LOOP,DG,DGM,DGZ,DGEG,DGEGS,DGX,DGX1,DG321,DG322,DGCT,DGY,DGY1,DGCTX,SSN
+5 DO CLLST(DFN,.DGCONF,.DGPOSS,.DGMSE)
+6 IF $GET(DGRPV)
SET $EXTRACT(DGRPVV(6),2,3)="00"
SET DGRPVV(6,"NOEDIT")=1
+7 IF '$GET(DGRPV)
IF $EXTRACT(DGRPVV(6),2,3)="11"
SET $EXTRACT(DGRPVV(6),2,3)="00"
SET DGRPVV(6,"NOEDIT")=1
+8 SET DGMSG=0
SET DGCTX=0
+9 ; Sort OEF/OIF/ UNKNOWN OEF/OIF
FOR Z="OEF","OIF","UNK"
Begin DoDot:1
+10 ; by reverse from dt within each conf
+11 SET Z0=Z
FOR
SET Z0=$ORDER(DGCONF(Z0))
IF Z0=""!(Z0'[Z)
QUIT
SET Z2=Z_"-"_(9999999-DGCONF(Z0))
SET DGCONFS(Z2)=$PIECE(Z0,"-",2)
IF 'DGMSG
IF $GET(DGCONF(Z0,1))
SET DGMSG=1
End DoDot:1
+12 SET DG321=$GET(^DPT(DFN,.321))
SET DG322=$GET(^(.322))
+13 ;
+14 SET DIR(0)="SA^"
SET DGCT=0
+15 SET X=$SELECT($DATA(^DPT(+DFN,0)):^(0),1:"")
SET SSN=$PIECE(X,"^",9)
SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,10)
+16 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$$SSNNM^DGRPU(DFN)
+17 SET DGCT=DGCT+1
SET DIR("A",DGCT)=""
SET $PIECE(DIR("A",DGCT),"=",81)=""
+18 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$SELECT($ORDER(DGMSE(0)):"MILITARY SERVICE PERIODS:",1:"NO SERVICE PERIODS FOR THIS PATIENT - NO CONFLICT LOC CAN BE ENTERED")
+19 SET Z=0
FOR
SET Z=$ORDER(DGMSE(Z))
IF 'Z!(Z>4)
QUIT
Begin DoDot:1
+20 IF Z=4
SET DGCT=DGCT+1
SET DIR("A",DGCT)=$JUSTIFY("",3)_"<more episodes>"
QUIT
+21 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$JUSTIFY("",3)_$EXTRACT($$EXTERNAL^DILFD(2,.325,"",$PIECE(DGMSE(Z),U,3))_$SELECT($PIECE(DGMSE(Z),U,4)'="":"/"_$$SVCCOMP($PIECE(DGMSE(Z),U,4)),1:"")_$JUSTIFY("",30),1,30)
+22 SET DIR("A",DGCT)=DIR("A",DGCT)_" ("_$SELECT($PIECE(DGMSE(Z),U):$$FMTE^XLFDT($PIECE(DGMSE(Z),U),"5DZ"),1:"missing")_"-"_$SELECT($PIECE(DGMSE(Z),U,2):$$FMTE^XLFDT($PIECE(DGMSE(Z),U,2),"5DZ"),1:"missing")_")"
End DoDot:1
+23 SET DGCT=DGCT+1
SET DIR("A",DGCT)=" "
+24 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$JUSTIFY("",24)_"---- CONFLICT LOCATIONS ----"
+25 SET DGCT=DGCT+1
SET DIR("A",DGCT)=$JUSTIFY("",34)_"FROM"_$JUSTIFY("",9)_"TO"_$JUSTIFY("",7)_"SOURCE (FOR OEF/OIF)"
+26 ; DGCONF(DGCONF,"OK")=# entries for OEF/OIF/ UNKNOWN OEF/OIF
+27 ; that are site-entered
+28 ; DGCONF(DGCONF,"OK",entry ien)=display #^formatted from dt^
+29 ; formatted to dt^inconsistent flag (valid entries for editing)
+30 SET DGEG=0
+31 FOR DGEGS=2,1,3
Begin DoDot:1
+32 SET DGCONF=$PIECE("OIF^OEF^UNK",U,DGEGS)
SET DGM=0
+33 SET DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
+34 SET DGEG=DGEG+1
+35 SET DGDISP=$SELECT(DGCONF'="UNK":$JUSTIFY("",8),1:"OEF/OIF ")_DGCONF_": "
+36 SET DGCT=DGCT+1
SET DGCTX=DGCT
SET DIR("A",DGCT)=" "_$EXTRACT(DG,1)_DGEG_$EXTRACT(DG,2)_" -"_DGDISP_$$YN($SELECT(DGCONF(DGCONF):"Y",'$DATA(^DPT(DFN,.3215,0)):"",1:"N"),1)
+37 IF $GET(DGCONF(DGCONF))!$DATA(DGPOSS(DGCONF))
IF '$GET(DGRPV)
IF $GET(DGCONF(DGCONF,"VEDIT"))'=2
IF '$GET(DGCONF(DGCONF,"NOEDIT"))
IF DGCONF'="UNK"
SET DIR(0)=DIR(0)_DGEG_":"_DGCONF_";"
+38 SET (DGZ,DGCONFS)=DGCONF
FOR
SET DGCONFS=$ORDER(DGCONFS(DGCONFS))
IF DGCONFS=""!(DGCONFS'[DGZ)
QUIT
Begin DoDot:2
+39 NEW DGUN,DGIEN,STA
+40 SET DGIEN=DGCONFS(DGCONFS)
SET DGCONF=DGZ_"-"_DGIEN
SET DGCONF1=DGZ
SET DGM=DGM+1
+41 IF $GET(DGCONF(DGCONF,1))
IF DGCTX
SET $EXTRACT(DIR("A",DGCTX),1,3)="***"
+42 SET DG=$$ISVALID^DGRP6CL2(.DGCONF,.DGPOSS)
+43 SET DGUN=$SELECT($GET(DGCONF(DGCONF,"NOEDIT")):1,1:0)
+44 IF 'DGUN
SET DGCONF(DGCONF1,"OK")=$GET(DGCONF(DGCONF1,"OK"))+1
SET DGCONF(DGCONF1,"OK",DGIEN)=DGM_U_$$FMTE^XLFDT($PIECE(DGCONF(DGCONF),U),"5DZ")_U_$$FMTE^XLFDT($PIECE(DGCONF(DGCONF),U,2),"5DZ")
+45 IF DGM>1
SET DGCT=DGCT+1
+46 SET DIR("A",DGCT)=$SELECT(DGM>1:$JUSTIFY("",27-$LENGTH(DGM)),1:DIR("A",DGCT)_" ")_"("_DGM_") "_$EXTRACT($$DAT(DGCONF(DGCONF),1,13)_$JUSTIFY("",12),1,12)_$EXTRACT($$DAT(DGCONF(DGCONF),2,11)_$JUSTIFY("",10),1,10)_" "
+47 SET STA=$PIECE(DGCONF(DGCONF),U,3)
+48 IF STA
SET STA=$PIECE($GET(^DIC(4,+STA,99)),U)
+49 SET DIR("A",DGCT)=DIR("A",DGCT)_$SELECT($PIECE(DGCONF(DGCONF),U,3)="CEV":"",1:"Station #")_$EXTRACT(STA_$JUSTIFY("",$SELECT('DGUN:6,1:3)),1,$SELECT('DGUN:6,1:3))
+50 IF DGUN
SET DIR("A",DGCT)=DIR("A",DGCT)_" (No Edit)"
End DoDot:2
End DoDot:1
+51 DO LOOPCNF^DGRP6CL1(.DGCONF,.DGPOSS,.DIR)
+52 SET DGCT=DGCT+1
SET DIR("A",DGCT)=" "
+53 IF $GET(DGMSG)
SET DGCT=DGCT+1
SET DIR("A",DGCT)="*** ==>OEF/OIF Dates are inconsistent with veteran's military service episodes"
+54 SET DIR("A")="SELECT THE NUMBER OF A CONFLICT LOCATION OR (Q)UIT: "
+55 SET DIR(0)=DIR(0)_"Q:QUIT"
+56 SET DIR("?")="^D HELP^DGRP6CL1($P(DIR(0),U,2))"
+57 SET DIR("B")="QUIT"
+58 DO ^DIR
KILL DIR
+59 IF $DATA(DUOUT)!$DATA(DTOUT)!(Y="Q")
IF Y'="Q"
SET QUIT=1
GOTO QUIT
+60 SET DGY=Y
SET DGY1=$SELECT(Y=2:1,Y=1:2,1:Y)
+61 IF DGY<4
SET DGCONF=""
+62 IF DGY'<4
Begin DoDot:1
+63 SET DGCONF=$PIECE("OEF^OIF^UNK^VIET^LEB^GREN^PAN^GULF^SOM^YUG",U,DGY)
+64 IF $GET(DGCONF(DGCONF,1))
WRITE !!,"WARNING - THIS CONFLICT IS INCONSISTENT WITH MILITARY SERVICE DATA",!
+65 SET DIE=2
SET DA=DFN
SET DR=$PIECE($TEXT(@DGCONF),";;",2)
IF DR'=""
DO ^DIE
KILL DIE,DA,DR
End DoDot:1
+66 IF DGY=1!(DGY=2)
Begin DoDot:1
+67 SET DGCONF=$PIECE("OEF^OIF",U,DGY)
+68 ; Add new only valid action
IF '$GET(DGCONF(DGCONF,"OK"))
IF $GET(DGCONF(DGCONF,"VEDIT"))'=2
DO ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF)
QUIT
+69 IF $GET(DGCONF(DGCONF,"VEDIT"))=1
SET DIR("A")="DO YOU WANT TO (A)DD OR (E)DIT "_DGCONF_" CONFLICT DATA?: "
SET DIR(0)="SA^A:ADD;E:EDIT"
SET DIR("B")="ADD"
DO ^DIR
KILL DIR
+70 IF $GET(DGCONF(DGCONF,"VEDIT"))=2
IF $GET(DGCONF(DGCONF,"OK"))
SET DIR("A")="DO YOU WANT TO EDIT "_DGCONF_" CONFLICT DATA?: "
SET DIR(0)="YA"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
SET Y=$SELECT(Y=1:"E",1:Y)
+71 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+72 IF Y="A"
DO ADDCFL^DGRP6CL1(DFN,DGY1,DGCONF)
QUIT
+73 IF Y="E"
Begin DoDot:2
+74 NEW DGXREF,IEN,DIR,X,Y
+75 IF DGCONF(DGCONF,"OK")=1
SET IEN=+$ORDER(DGCONF(DGCONF,"OK",0))
IF IEN
DO EDCFL^DGRP6CL1(DFN,IEN,$GET(DGCONF(DGCONF,"VEDIT")))
QUIT
+76 SET DIR(0)="SA^"
SET DIR("A")="SELECT THE # OF THE "_DGCONF_" CONFLICT PERIOD TO EDIT: "
SET DIR("A",1)=" "
+77 SET Z=0
FOR
SET Z=$ORDER(DGCONF(DGCONF,"OK",Z))
IF 'Z
QUIT
SET Z0=DGCONF(DGCONF,"OK",Z)
SET DIR(0)=DIR(0)_+Z0_":"_$PIECE(Z0,U,2)_$SELECT($PIECE(Z0,U,3)'="":"-"_$PIECE(Z0,U,3),1:"")_";"
SET DGXREF(+Z0)=Z
+78 SET DIR(0)=DIR(0)_"Q:QUIT"
+79 DO ^DIR
KILL DIR
+80 IF Y
DO EDCFL^DGRP6CL1(DFN,+$GET(DGXREF(+Y)),$GET(DGCONF(DGCONF,"VEDIT")))
End DoDot:2
End DoDot:1
+81 GOTO EN1
+82 ;
QUIT QUIT
+1 ;
EN2 ; Consistency checker re-edit entrypoint for OEF/OIF data
+1 NEW DGOEIF,DGZ,DGQUIT,Z,Z0,Y
+2 DO GET^DGENOEIF(DFN,.DGOEIF,2,"",1)
+3 IF $GET(DGOEIF("COUNT"))&($ORDER(DGOEIF("OIF",0))!$ORDER(DGOEIF("OEF",0)))
Begin DoDot:1
+4 FOR Z="OEF","OIF"
SET Z0=0
FOR
SET Z0=$ORDER(DGOEIF(Z,Z0))
IF 'Z0
QUIT
IF $GET(DGOEIF(Z,Z0,"IEN"))
SET DGZ(DGOEIF(Z,Z0,"IEN"))=""
+5 SET (DGQUIT,DGZ)=0
FOR
SET DGZ=$ORDER(DGZ(DGZ))
IF 'DGZ
QUIT
Begin DoDot:2
+6 NEW DGX,DA,DIE,DR,X
+7 SET DGX=$GET(^DPT(DFN,.3215,DGZ,0))
+8 WRITE !!,"OEF/OIF CONFLICT: ",$$EXTERNAL^DILFD(2.3215,.01,"",$PIECE(DGX,U))," FROM: "_$$EXTERNAL^DILFD(2.3215,.02,"",$PIECE(DGX,U,2))," TO: "_$$EXTERNAL^DILFD(2.3215,.03,"",$PIECE(DGX,U,3))
+9 SET DA=DGZ
SET DA(1)=DFN
SET DIE="^DPT("_DA(1)_",.3215,"
SET DR=".01;.02R;.03R"
DO ^DIE
IF $DATA(Y)
SET DGQUIT=1
End DoDot:2
IF DGQUIT
QUIT
End DoDot:1
+10 QUIT
+11 ;
SVCCOMP(X) ; Returns display text for service component
+1 QUIT $SELECT(X="R":"REGULAR",X="V":"RESERVE",X="G":"GUARD",1:"")
+2 ;
VIET ;;.32101//NO;S:X'="Y" Y="@64";.32104;.32105;@64;
LEB ;;.3221//NO;S:X'="Y" Y="@67";.3222;Q;.3223;@67;
GREN ;;.3224//NO;S:X'="Y" Y="@68";.3225;Q;.3226;@68;
PAN ;;.3227//NO;S:X'="Y" Y="@69";.3228;Q;.3229;@69;
GULF ;;.32201//NO;S:X'="Y" Y="@610";.322011;Q;.322012;@610;
SOM ;;.322016//NO;S:X'="Y" Y="@611";.322017;Q;.322018;@611;
YUG ;;.322019//NO;S:X'="Y" Y="@615";.32202;Q;.322021;@615;
OEF ;;
OIF ;;
UNK ;;
+1 ;;
