Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGMSEUTL

DGMSEUTL.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;
  1. MOVMSE(DFN) ;Move MSE data from .32 node to .3216 multiple in Patient file #2
  1. Q:'$G(DFN) Q:$O(^DPT(DFN,.3216,0))
  1. N ARRAY
  1. D ARRAY(DFN,.ARRAY)
  1. I $D(ARRAY) D MSE(DFN,.ARRAY)
  1. Q
  1. ;
  1. ARRAY(DFN,ARRAY) ;Get old format VistA data
  1. N DGRP,DGRPX,DGRPED,DGRPSD,DGRPBR,DGRPCO,DGRPSN,DGRPDI
  1. S DGRP(.32)=$G(^DPT(DFN,.32)),DGRP(.3291)=$G(^DPT(DFN,.3291))
  1. ;Last service episode (SL)
  1. D EPISODE(1,4,8)
  1. ;Next to last service episode (SNL)
  1. Q:$P(DGRP(.32),"^",19)'="Y" D EPISODE(2,9,13)
  1. ;Prior episode (SNNL)
  1. I $P(DGRP(.32),"^",20)="Y" D EPISODE(3,14,18)
  1. Q
  1. ;
  1. EPISODE(SUB,P1,P2) ;Get old VistA data and save
  1. S DGRPX=$P(DGRP(.32),U,P1,P2),DGRPCO=$P(DGRP(.3291),U,SUB)
  1. S DGRPDI=$P(DGRPX,U),DGRPBR=$P(DGRPX,U,2),DGRPED=$P(DGRPX,U,3)
  1. S DGRPSD=$P(DGRPX,U,4),DGRPSN=$P(DGRPX,U,5)
  1. ;DJS, Save Future Discharge Date; DG*5.3*935
  1. ;Save in format of new .3216 multiple (no lock flag)
  1. S ARRAY(SUB)=DGRPED_U_DGRPSD_U_DGRPBR_U_DGRPCO_U_DGRPSN_U_DGRPDI_U_U_$G(DGFDD) ; DG*5.3*935
  1. Q
  1. ;
  1. MSE(DFN,ARRAY,DEL) ;Copy old VistA data to new .3216 multiple
  1. N ECNT,DA,DIK,SUB,X,Y,DIC,DLAYGO,FLDS,DGFDD,DGNEW
  1. S ECNT=0
  1. ;Delete existing entries
  1. I $G(DEL) F S ECNT=$O(^DPT(DFN,.3216,ECNT)) Q:+ECNT'>0 D
  1. .S DA(1)=DFN,DA=ECNT,DIK="^DPT("_DA(1)_",.3216," D ^DIK
  1. ;Add service episodes
  1. S SUB=""
  1. F S SUB=$O(ARRAY(SUB)) Q:'SUB D
  1. .;Ignore if Service Entry Date is null
  1. .Q:'+ARRAY(SUB)
  1. .N DA,DIC,DD,DO,DLAYGO,FLDS,X
  1. .S FLDS=ARRAY(SUB)
  1. .S DIC="^DPT(DFN,.3216,"
  1. .S DIC(0)="L",DLAYGO=2
  1. .S DA(1)=DFN
  1. .S X=$P(FLDS,U) ;Entry Date
  1. .S DIC("DR")=".02////"_$P(FLDS,U,2) ;Separation Date
  1. .S DIC("DR")=DIC("DR")_";.03////"_$P(FLDS,U,3) ;Service Branch
  1. .S DIC("DR")=DIC("DR")_";.04////"_$P(FLDS,U,4) ;Service Component
  1. .S DIC("DR")=DIC("DR")_";.05////"_$P(FLDS,U,5) ;Service Number
  1. .S DIC("DR")=DIC("DR")_";.06////"_$P(FLDS,U,6) ;Discharge type
  1. .S DIC("DR")=DIC("DR")_";.07////"_$P(FLDS,U,7) ;Locked
  1. . ;DJS, Store FUTURE DISCHARGE DATE; DG*5.3*935
  1. .S DIC("DR")=DIC("DR")_";.08///"_$P(FLDS,U,8) ;Future Discharge Date
  1. .;jam; Store REASON FOR EARLY SEPARATION - DG*5.3*947
  1. .;jam; Store REASON FOR EARLY SEPARATION ONLY if no SEPARATION REASON CODE sent - DG*5.3*966
  1. .I $P(FLDS,U,10)="" S DIC("DR")=DIC("DR")_";.09///"_$P(FLDS,U,9) ;Reason for Early Separation
  1. .E D
  1. ..;jam; Store SEPARATION REASON CODE ONLY if it exists in File 26, otherwise store
  1. ..; informational message in the REASON FOR EARLY SEPARATION field - DG*5.3*966
  1. ..I $$FIND1^DIC(26,,"B",$P(FLDS,U,10)) S DIC("DR")=DIC("DR")_";.1///"_$P(FLDS,U,10) ;Separation Reason Code
  1. ..E S DIC("DR")=DIC("DR")_";.09///"_"Refer to Enrollment System for Reason" ;Reason For Early Separation
  1. .D FILE^DICN
  1. Q
  1. ;
  1. 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
  1. ;subscript is the MSE IEN in the multiple e.g. MSE(1,4)=last
  1. I '$G(DFN) Q
  1. N I,SDT,IEN
  1. S SDT=""
  1. F I=1:1 S SDT=$O(^DPT(DFN,.3216,"B",SDT),-1) Q:'SDT D
  1. .S IEN=0 F S IEN=$O(^DPT(DFN,.3216,"B",SDT,IEN)) Q:'IEN D
  1. ..I '$D(^DPT(DFN,.3216,IEN,0)) Q
  1. ..S MSE(I)=^DPT(DFN,.3216,IEN,0)
  1. ..S MSE(I,IEN)=""
  1. Q
  1. ;
  1. LAST(DFN) ;Return last (most recent) MSE
  1. I '$G(DFN) Q ""
  1. N MSE
  1. D GETMSE(DFN,.MSE)
  1. S MSE=$O(MSE(0))
  1. Q $G(MSE(+MSE))
  1. ;
  1. UPDMSE(DFN,DGNMSE) ;File MSE data from the HEC Z11 message
  1. Q:'$G(DFN) Q:'$D(DGNMSE)
  1. N DGOMSE,DGTOT,DGCHG,DGN,DGO,I
  1. S DGTOT=0,DGN="" F S DGN=$O(DGNMSE(DGN)) Q:'DGN S DGTOT=DGTOT+1
  1. ;Get current MSE data for patient from MSE sub-file #2.3216
  1. D GETMSE(DFN,.DGOMSE)
  1. I $D(DGOMSE) D Q:'DGCHG
  1. .;Compare the old and new data. If they match, no update is needed.
  1. .S DGCHG=0
  1. .I DGTOT'=$O(DGOMSE(""),-1) S DGCHG=1 Q
  1. .S (DGO,DGN)=""
  1. .F I=1:1:DGTOT S DGO=$O(DGOMSE(DGO)),DGN=$O(DGNMSE(DGN)) D Q:DGCHG
  1. ..I DGOMSE(DGO)'=DGNMSE(DGN) S DGCHG=1 Q
  1. ;File the new MSE data from HEC, delete old data first if it exists
  1. D MSE(DFN,.DGNMSE,$D(DGOMSE))
  1. Q
  1. ;
  1. ESRDATA(DFN) ;Check if any records in .3216 are from ESR
  1. N IEN,LOCKED
  1. S IEN=0,LOCKED=0
  1. F S IEN=$O(^DPT(DFN,.3216,IEN)) Q:'IEN D Q:LOCKED
  1. .;Check if record is locked
  1. .S LOCKED=$P($G(^DPT(DFN,.3216,IEN,0)),U,7)
  1. ;Return LOCKED indicating ESR data found
  1. Q LOCKED
  1. ;
  1. WARNMSG(DFN) ;Warning Message if some episodes did not copy
  1. N DATA32,OLDMSE,NEWMSE,DATA
  1. ;If ESR data exists quit
  1. Q:$$ESRDATA(DFN) 0
  1. ;Count number of old episodes
  1. N LBRANCH,LDATE,SDAT,NODT
  1. S DATA32=$G(^DPT(DFN,.32))
  1. S LDATE=$P(DATA32,U,6),LBRANCH=$P(DATA32,U,5),OLDMSE=0,NODT=0
  1. ;If entry date or branch assume last episode exists
  1. I LDATE!LBRANCH S OLDMSE=OLDMSE+1 S:'LDATE NODT=1
  1. ;Check for second episode
  1. I $P(DATA32,U,19)="Y" D
  1. .S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,11) NODT=1
  1. .;and third episode
  1. .I $P(DATA32,U,20)="Y" S OLDMSE=OLDMSE+1 S:'$P(DATA32,U,16) NODT=1
  1. ;
  1. ;If no old episodes no message is necessary
  1. Q:'OLDMSE 0
  1. ;
  1. ;Count number of new episodes
  1. S NEWMSE=0,SDAT=""
  1. F S SDAT=$O(^DPT(DFN,.3216,"B",SDAT),-1) Q:'SDAT D
  1. .S IEN=$O(^DPT(DFN,.3216,"B",SDAT,0)) Q:'IEN
  1. .S DATA=$G(^DPT(DFN,.3216,IEN,0)) Q:DATA=""
  1. .S NEWMSE=NEWMSE+1
  1. ;
  1. ;If number old MSEs greater than new MSEs, and service entry date
  1. ;is missing, return 1
  1. I OLDMSE>NEWMSE,NODT Q 1
  1. ;Otherwise, return 0
  1. Q 0