DGMSEUTL ;ALB/PJH,LBD,DJS,KUM,JAM - MSDS Utility Routine ;12 June 2018 5:36PM
;;5.3;Registration;**797,935,947,966**;08/13/93;Build 8
;
;
MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2
Q:'$G(DFN) Q:$O(^DPT(DFN,.3216,0))
N ARRAY
D ARRAY(DFN,.ARRAY)
I $D(ARRAY) D MSE(DFN,.ARRAY)
Q
;
ARRAY(DFN,ARRAY) ;Get old format VistA data
N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
;Last service episode (SL)
D EPISODE(1,4,8)
;Next to last service episode (SNL)
Q:$P(DGRP(.32),"^",19)'="Y" D EPISODE(2,9,13)
;Prior episode (SNNL)
I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
Q
;
EPISODE(SUB,P1,P2) ;Get old VistA data and save
S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
;DJS, Save Future Discharge Date; DG*5.3*935
;Save in format of new .3216 multiple (no lock flag)
S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U_U_$G(DGFDD) ; DG*5.3*935
Q
;
MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple
N ECNT,DA,DIK,SUB,X,Y,DIC,DLAYGO,FLDS,DGFDD,DGNEW
S ECNT=0
;Delete existing entries
I $G(DEL) F S ECNT=$O(^DPT(DFN,.3216,ECNT)) Q:+ECNT'>0 D
.S DA(1)=DFN,DA=ECNT,DIK="^DPT("_DA(1)_",.3216," D ^DIK
;Add service episodes
S SUB=""
F S SUB=$O(ARRAY(SUB)) Q:'SUB D
.;Ignore if Service Entry Date is null
.Q:'+ARRAY(SUB)
.N DA,DIC,DD,DO,DLAYGO,FLDS,X
.S FLDS=ARRAY(SUB)
.S DIC="^DPT(DFN,.3216,"
.S DIC(0)="L",DLAYGO=2
.S DA(1)=DFN
.S X=$P(FLDS,U) ;Entry Date
.S DIC("DR")=".02////"_$P(FLDS,U,2) ;Separation Date
.S DIC("DR")=DIC("DR")_";.03////"_$P(FLDS,U,3) ;Service Branch
.S DIC("DR")=DIC("DR")_";.04////"_$P(FLDS,U,4) ;Service Component
.S DIC("DR")=DIC("DR")_";.05////"_$P(FLDS,U,5) ;Service Number
.S DIC("DR")=DIC("DR")_";.06////"_$P(FLDS,U,6) ;Discharge type
.S DIC("DR")=DIC("DR")_";.07////"_$P(FLDS,U,7) ;Locked
. ;DJS, Store FUTURE DISCHARGE DATE; DG*5.3*935
.S DIC("DR")=DIC("DR")_";.08///"_$P(FLDS,U,8) ;Future Discharge Date
.;jam; Store REASON FOR EARLY SEPARATION - DG*5.3*947
.;jam; Store REASON FOR EARLY SEPARATION ONLY if no SEPARATION REASON CODE sent - DG*5.3*966
.I $P(FLDS,U,10)="" S DIC("DR")=DIC("DR")_";.09///"_$P(FLDS,U,9) ;Reason for Early Separation
.E D
..;jam; Store SEPARATION REASON CODE ONLY if it exists in File 26, otherwise store
..; informational message in the REASON FOR EARLY SEPARATION field - DG*5.3*966
..I $$FIND1^DIC(26,,"B",$P(FLDS,U,10)) S DIC("DR")=DIC("DR")_";.1///"_$P(FLDS,U,10) ;Separation Reason Code
..E S DIC("DR")=DIC("DR")_";.09///"_"Refer to Enrollment System for Reason" ;Reason For Early Separation
.D FILE^DICN
Q
;
GETMSE(DFN,MSE) ;Return all records in MSE sub-file #2.3216 in MSE array
;Records are sorted in reverse chronological order and the second
;subscript is the MSE IEN in the multiple e.g. MSE(1,4)=last
I '$G(DFN) Q
N I,SDT,IEN
S SDT=""
F I=1:1 S SDT=$O(^DPT(DFN,.3216,"B",SDT),-1) Q:'SDT D
.S IEN=0 F S IEN=$O(^DPT(DFN,.3216,"B",SDT,IEN)) Q:'IEN D
..I '$D(^DPT(DFN,.3216,IEN,0)) Q
..S MSE(I)=^DPT(DFN,.3216,IEN,0)
..S MSE(I,IEN)=""
Q
;
LAST(DFN) ;Return last (most recent) MSE
I '$G(DFN) Q ""
N MSE
D GETMSE(DFN,.MSE)
S MSE=$O(MSE(0))
Q $G(MSE(+MSE))
;
UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message
Q:'$G(DFN) Q:'$D(DGNMSE)
N DGOMSE,DGTOT,DGCHG,DGN,DGO,I
S DGTOT=0,DGN="" F S DGN=$O(DGNMSE(DGN)) Q:'DGN S DGTOT=DGTOT+1
;Get current MSE data for patient from MSE sub-file #2.3216
D GETMSE(DFN,.DGOMSE)
I $D(DGOMSE) D Q:'DGCHG
.;Compare the old and new data. If they match, no update is needed.
.S DGCHG=0
.I DGTOT'=$O(DGOMSE(""),-1) S DGCHG=1 Q
.S (DGO,DGN)=""
.F I=1:1:DGTOT S DGO=$O(DGOMSE(DGO)),DGN=$O(DGNMSE(DGN)) D Q:DGCHG
..I DGOMSE(DGO)'=DGNMSE(DGN) S DGCHG=1 Q
;File the new MSE data from HEC, delete old data first if it exists
D MSE(DFN,.DGNMSE,$D(DGOMSE))
Q
;
ESRDATA(DFN) ;Check if any records in .3216 are from ESR
N IEN,LOCKED
S IEN=0,LOCKED=0
F S IEN=$O(^DPT(DFN,.3216,IEN)) Q:'IEN D Q:LOCKED
.;Check if record is locked
.S LOCKED=$P($G(^DPT(DFN,.3216,IEN,0)),U,7)
;Return LOCKED indicating ESR data found
Q LOCKED
;
WARNMSG(DFN) ;Warning Message if some episodes did not copy
N DATA32,OLDMSE,NEWMSE,DATA
;If ESR data exists quit
Q:$$ESRDATA(DFN) 0
;Count number of old episodes
N LBRANCH,LDATE,SDAT,NODT
S DATA32=$G(^DPT(DFN,.32))
S LDATE=$P(DATA32,U,6),LBRANCH=$P(DATA32,U,5),OLDMSE=0,NODT=0
;If entry date or branch assume last episode exists
I LDATE!LBRANCH S OLDMSE=OLDMSE+1 S:'LDATE NODT=1
;Check for second episode
I $P(DATA32,U,19)="Y" D
.S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,11) NODT=1
.;and third episode
.I $P(DATA32,U,20)="Y" S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,16) NODT=1
;
;If no old episodes no message is necessary
Q:'OLDMSE 0
;
;Count number of new episodes
S NEWMSE=0,SDAT=""
F S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT D
.S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
.S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
.S NEWMSE=NEWMSE+1
;
;If number old MSEs greater than new MSEs, and service entry date
;is missing, return 1
I OLDMSE>NEWMSE,NODT Q 1
;Otherwise, return 0
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGMSEUTL 5432 printed Dec 13, 2024@02:44:19 Page 2
DGMSEUTL ;ALB/PJH,LBD,DJS,KUM,JAM - MSDS Utility Routine ;12 June 2018 5:36PM
+1 ;;5.3;Registration;**797,935,947,966**;08/13/93;Build 8
+2 ;
+3 ;
MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2
+1 if '$GET(DFN)
QUIT
if $ORDER(^DPT(DFN,.3216,0))
QUIT
+2 NEW ARRAY
+3 DO ARRAY(DFN,.ARRAY)
+4 IF $DATA(ARRAY)
DO MSE(DFN,.ARRAY)
+5 QUIT
+6 ;
ARRAY(DFN,ARRAY) ;Get old format VistA data
+1 NEW DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
+2 SET DGRP(.32)=$GET(^DPT(DFN,.32))
SET DGRP(.3291)=$GET(^DPT(DFN,.3291))
+3 ;Last service episode (SL)
+4 DO EPISODE(1,4,8)
+5 ;Next to last service episode (SNL)
+6 if $PIECE(DGRP(.32),"^",19)'="Y"
QUIT
DO EPISODE(2,9,13)
+7 ;Prior episode (SNNL)
+8 IF $PIECE(DGRP(.32),"^",20)="Y"
DO EPISODE(3,14,18)
+9 QUIT
+10 ;
EPISODE(SUB,P1,P2) ;Get old VistA data and save
+1 SET DGRPX=$PIECE(DGRP(.32),U,P1,P2)
SET DGRPCO=$PIECE(DGRP(.3291),U,SUB)
+2 SET DGRPDI=$PIECE(DGRPX,U)
SET DGRPBR=$PIECE(DGRPX,U,2)
SET DGRPED=$PIECE(DGRPX,U,3)
+3 SET DGRPSD=$PIECE(DGRPX,U,4)
SET DGRPSN=$PIECE(DGRPX,U,5)
+4 ;DJS, Save Future Discharge Date; DG*5.3*935
+5 ;Save in format of new .3216 multiple (no lock flag)
+6 ; DG*5.3*935
SET ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U_U_$GET(DGFDD)
+7 QUIT
+8 ;
MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple
+1 NEW ECNT,DA,DIK,SUB,X,Y,DIC,DLAYGO,FLDS,DGFDD,DGNEW
+2 SET ECNT=0
+3 ;Delete existing entries
+4 IF $GET(DEL)
FOR
SET ECNT=$ORDER(^DPT(DFN,.3216,ECNT))
if +ECNT'>0
QUIT
Begin DoDot:1
+5 SET DA(1)=DFN
SET DA=ECNT
SET DIK="^DPT("_DA(1)_",.3216,"
DO ^DIK
End DoDot:1
+6 ;Add service episodes
+7 SET SUB=""
+8 FOR
SET SUB=$ORDER(ARRAY(SUB))
if 'SUB
QUIT
Begin DoDot:1
+9 ;Ignore if Service Entry Date is null
+10 if '+ARRAY(SUB)
QUIT
+11 NEW DA,DIC,DD,DO,DLAYGO,FLDS,X
+12 SET FLDS=ARRAY(SUB)
+13 SET DIC="^DPT(DFN,.3216,"
+14 SET DIC(0)="L"
SET DLAYGO=2
+15 SET DA(1)=DFN
+16 ;Entry Date
SET X=$PIECE(FLDS,U)
+17 ;Separation Date
SET DIC("DR")=".02////"_$PIECE(FLDS,U,2)
+18 ;Service Branch
SET DIC("DR")=DIC("DR")_";.03////"_$PIECE(FLDS,U,3)
+19 ;Service Component
SET DIC("DR")=DIC("DR")_";.04////"_$PIECE(FLDS,U,4)
+20 ;Service Number
SET DIC("DR")=DIC("DR")_";.05////"_$PIECE(FLDS,U,5)
+21 ;Discharge type
SET DIC("DR")=DIC("DR")_";.06////"_$PIECE(FLDS,U,6)
+22 ;Locked
SET DIC("DR")=DIC("DR")_";.07////"_$PIECE(FLDS,U,7)
+23 ;DJS, Store FUTURE DISCHARGE DATE; DG*5.3*935
+24 ;Future Discharge Date
SET DIC("DR")=DIC("DR")_";.08///"_$PIECE(FLDS,U,8)
+25 ;jam; Store REASON FOR EARLY SEPARATION - DG*5.3*947
+26 ;jam; Store REASON FOR EARLY SEPARATION ONLY if no SEPARATION REASON CODE sent - DG*5.3*966
+27 ;Reason for Early Separation
IF $PIECE(FLDS,U,10)=""
SET DIC("DR")=DIC("DR")_";.09///"_$PIECE(FLDS,U,9)
+28 IF '$TEST
Begin DoDot:2
+29 ;jam; Store SEPARATION REASON CODE ONLY if it exists in File 26, otherwise store
+30 ; informational message in the REASON FOR EARLY SEPARATION field - DG*5.3*966
+31 ;Separation Reason Code
IF $$FIND1^DIC(26,,"B",$PIECE(FLDS,U,10))
SET DIC("DR")=DIC("DR")_";.1///"_$PIECE(FLDS,U,10)
+32 ;Reason For Early Separation
IF '$TEST
SET DIC("DR")=DIC("DR")_";.09///"_"Refer to Enrollment System for Reason"
End DoDot:2
+33 DO FILE^DICN
End DoDot:1
+34 QUIT
+35 ;
GETMSE(DFN,MSE) ;Return all records in MSE sub-file #2.3216 in MSE array
+1 ;Records are sorted in reverse chronological order and the second
+2 ;subscript is the MSE IEN in the multiple e.g. MSE(1,4)=last
+3 IF '$GET(DFN)
QUIT
+4 NEW I,SDT,IEN
+5 SET SDT=""
+6 FOR I=1:1
SET SDT=$ORDER(^DPT(DFN,.3216,"B",SDT),-1)
if 'SDT
QUIT
Begin DoDot:1
+7 SET IEN=0
FOR
SET IEN=$ORDER(^DPT(DFN,.3216,"B",SDT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+8 IF '$DATA(^DPT(DFN,.3216,IEN,0))
QUIT
+9 SET MSE(I)=^DPT(DFN,.3216,IEN,0)
+10 SET MSE(I,IEN)=""
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
LAST(DFN) ;Return last (most recent) MSE
+1 IF '$GET(DFN)
QUIT ""
+2 NEW MSE
+3 DO GETMSE(DFN,.MSE)
+4 SET MSE=$ORDER(MSE(0))
+5 QUIT $GET(MSE(+MSE))
+6 ;
UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message
+1 if '$GET(DFN)
QUIT
if '$DATA(DGNMSE)
QUIT
+2 NEW DGOMSE,DGTOT,DGCHG,DGN,DGO,I
+3 SET DGTOT=0
SET DGN=""
FOR
SET DGN=$ORDER(DGNMSE(DGN))
if 'DGN
QUIT
SET DGTOT=DGTOT+1
+4 ;Get current MSE data for patient from MSE sub-file #2.3216
+5 DO GETMSE(DFN,.DGOMSE)
+6 IF $DATA(DGOMSE)
Begin DoDot:1
+7 ;Compare the old and new data. If they match, no update is needed.
+8 SET DGCHG=0
+9 IF DGTOT'=$ORDER(DGOMSE(""),-1)
SET DGCHG=1
QUIT
+10 SET (DGO,DGN)=""
+11 FOR I=1:1:DGTOT
SET DGO=$ORDER(DGOMSE(DGO))
SET DGN=$ORDER(DGNMSE(DGN))
Begin DoDot:2
+12 IF DGOMSE(DGO)'=DGNMSE(DGN)
SET DGCHG=1
QUIT
End DoDot:2
if DGCHG
QUIT
End DoDot:1
if 'DGCHG
QUIT
+13 ;File the new MSE data from HEC, delete old data first if it exists
+14 DO MSE(DFN,.DGNMSE,$DATA(DGOMSE))
+15 QUIT
+16 ;
ESRDATA(DFN) ;Check if any records in .3216 are from ESR
+1 NEW IEN,LOCKED
+2 SET IEN=0
SET LOCKED=0
+3 FOR
SET IEN=$ORDER(^DPT(DFN,.3216,IEN))
if 'IEN
QUIT
Begin DoDot:1
+4 ;Check if record is locked
+5 SET LOCKED=$PIECE($GET(^DPT(DFN,.3216,IEN,0)),U,7)
End DoDot:1
if LOCKED
QUIT
+6 ;Return LOCKED indicating ESR data found
+7 QUIT LOCKED
+8 ;
WARNMSG(DFN) ;Warning Message if some episodes did not copy
+1 NEW DATA32,OLDMSE,NEWMSE,DATA
+2 ;If ESR data exists quit
+3 if $$ESRDATA(DFN)
QUIT 0
+4 ;Count number of old episodes
+5 NEW LBRANCH,LDATE,SDAT,NODT
+6 SET DATA32=$GET(^DPT(DFN,.32))
+7 SET LDATE=$PIECE(DATA32,U,6)
SET LBRANCH=$PIECE(DATA32,U,5)
SET OLDMSE=0
SET NODT=0
+8 ;If entry date or branch assume last episode exists
+9 IF LDATE!LBRANCH
SET OLDMSE=OLDMSE+1
if 'LDATE
SET NODT=1
+10 ;Check for second episode
+11 IF $PIECE(DATA32,U,19)="Y"
Begin DoDot:1
+12 SET OLDMSE=OLDMSE+1
if '$PIECE(DATA32,U,11)
SET NODT=1
+13 ;and third episode
+14 IF $PIECE(DATA32,U,20)="Y"
SET OLDMSE=OLDMSE+1
if '$PIECE(DATA32,U,16)
SET NODT=1
End DoDot:1
+15 ;
+16 ;If no old episodes no message is necessary
+17 if 'OLDMSE
QUIT 0
+18 ;
+19 ;Count number of new episodes
+20 SET NEWMSE=0
SET SDAT=""
+21 FOR
SET SDAT=$ORDER(^DPT(DFN,.3216,"B",SDAT),-1)
if 'SDAT
QUIT
Begin DoDot:1
+22 SET IEN=$ORDER(^DPT(DFN,.3216,"B",SDAT,0))
if 'IEN
QUIT
+23 SET DATA=$GET(^DPT(DFN,.3216,IEN,0))
if DATA=""
QUIT
+24 SET NEWMSE=NEWMSE+1
End DoDot:1
+25 ;
+26 ;If number old MSEs greater than new MSEs, and service entry date
+27 ;is missing, return 1
+28 IF OLDMSE>NEWMSE
IF NODT
QUIT 1
+29 ;Otherwise, return 0
+30 QUIT 0
