- 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 Feb 19, 2025@00:10:22 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