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

PXRMP6ID.m

Go to the documentation of this file. 
  1. PXRMP6ID ; SLC/AGP - Inits for PXRM*2.0*6 ;11/25/2007
  1.  ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
  1.  ;
  1.  Q
  1.  ;====================================================
  1. BDICONV ;
  1.  N BDI,BDI2,DA,DIE,DR,ITEM,NAME,NLINES,RGBDI,RGBDI2,TEXT
  1.  K ^TMP("PXRMXMZ",$J)
  1.  S TEXT(1)="Converting Dialog Elements from BDI to BDI2."
  1.  S TEXT(2)="See Mailman message for more details."
  1.  D MES^XPDUTL(.TEXT)
  1.  S NLINES=1,TEXT="Dialog Elements names that were converted."
  1.  S ^TMP("PXRMXMZ",$J,NLINES,0)=TEXT
  1.  S DIE="^PXRMD(801.41,"
  1.  S BDI=$O(^YTT(601,"B","BDI","")) Q:BDI'>0
  1.  S BDI2=$O(^YTT(601,"B","BDI2","")) Q:BDI2'>0
  1.  S BDI=BDI_";YTT(601,",BDI2=BDI2_";YTT(601,"
  1.  S RGBDI=$O(^PXRMD(801.41,"B","PXRM BDI RESULT GROUP","")) Q:RGBDI'>0
  1.  S RGBDI2=$O(^PXRMD(801.41,"B","PXRM BDI II RESULT GROUP","")) Q:RGBDI2'>0
  1.  S DA=0 F  S DA=$O(^PXRMD(801.41,DA)) Q:DA'>0  D
  1.  .S ITEM=$P($G(^PXRMD(801.41,DA,1)),U,5) Q:ITEM'>0
  1.  .I BDI=ITEM D
  1.  ..S NAME=$P($G(^PXRMD(801.41,DA,0)),U)
  1.  ..S DR="15////^S X=BDI2"
  1.  ..I $P($G(^PXRMD(801.41,DA,0)),U,15)=RGBDI D
  1.  ...S DR=DR_";55////^S X=RGBDI2" D ^DIE
  1.  ..D ^DIE
  1.  ..S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=NAME
  1.  I NLINES=1 D
  1.  .S NLINES=NLINES+1
  1.  .S ^TMP("PXRMXMZ",$J,NLINES,0)="No dialog elements were converted."
  1.  D SEND^PXRMMSG("Dialog elements converted from BDI to BDI2")
  1.  K ^TMP("PXRMXMZ",$J)
  1.  Q
  1. CHECKRG ;
  1.  ;list non-National Result Groups that need to be mapped to a MH finding
  1.  N DIEN,NLINES,NODE,TEXT
  1.  K ^TMP("PXRMXMZ",$J)
  1.  S NLINES=0
  1.  S DIEN=0 F  S DIEN=$O(^PXRMD(801.41,DIEN)) Q:DIEN'>0  D
  1.  .S NODE=$G(^PXRMD(801.41,DIEN,0))
  1.  .I $P(NODE,U,4)'="S" Q
  1.  .I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q
  1.  .S TEXT="Result Group: "_$P(NODE,U)_" needs to be mapped to an MH test and scale."
  1.  .S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=TEXT
  1.  .S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=""
  1.  S TEXT="Dialog Results Groups that need to be mapped to a MH Test."
  1.  I NLINES>0 D SEND^PXRMMSG(TEXT)
  1.  K ^TMP("PXRMXMZ",$J)
  1.  Q
  1.  ;
  1. DCLEAN ;
  1.  N CNT,DA,DIEN,DIK,EARRAY,EIEN,RIEN,TEXT
  1.  S RIEN=$O(^PXD(811.9,"B","PXRM RESULT GROUP UPDATE REMINDER",""))
  1.  Q:RIEN'>0
  1.  S DIEN=$P($G(^PXD(811.9,RIEN,51)),U) Q:DIEN'>0
  1.  S TEXT="Removing transport reminder and dialog for Result Groups."
  1.  D MES^XPDUTL(.TEXT)
  1.  S CNT=0 F  S CNT=$O(^PXRMD(801.41,DIEN,10,CNT)) Q:CNT'>0  D
  1.  .S EIEN=$P($G(^PXRMD(801.41,DIEN,10,CNT,0)),U,2)
  1.  .I $P($P($G(^PXRMD(801.41,EIEN,0)),U)," ")'="PXRM" Q
  1.  .S EARRAY(EIEN)=""
  1.  S DIK="^PXRMD(801.41,"
  1.  S DA="" F  S DA=$O(EARRAY(DA)) Q:DA'>0  D ^DIK
  1.  S DA=DIEN D ^DIK
  1.  S DIK="^PXD(811.9,",DA=RIEN D ^DIK
  1.  Q
  1.  ;
  1. REINDEX ;
  1.  S DIK="^PXRMD(801.41,",DIK(1)=4 D ENALL^DIK
  1.  Q 
  1. STORERG ;
  1.  ;store result groups for an element in XTMP
  1.  N CNT,DIEN,RGIEN,PXRMXTMP,TYPE
  1.  ;S PXRMXTMP="PXRM"_$$NOW^XLFDT
  1.  S PXRMXTMP="PXRM PATCH 6"
  1.  K ^XTMP(PXRMXTMP)
  1.  S ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"PXRM PATCH 6 DIALOG CONVERSION"
  1.  S DIEN=0,CNT=0 F  S DIEN=$O(^PXRMD(801.41,DIEN)) Q:DIEN'>0  D
  1.  .S TYPE=$P($G(^PXRMD(801.41,DIEN,0)),U,4)
  1.  .I TYPE'="E",TYPE'="G" Q
  1.  .I $P($G(^PXRMD(801.41,DIEN,0)),U,15)="" Q
  1.  .S CNT=CNT+1
  1.  .S ^XTMP(PXRMXTMP,"PXRM DCONV",CNT)=DIEN_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,15)
  1.  .S $P(^PXRMD(801.41,DIEN,0),U,15)=""
  1.  Q
  1.  ;
  1. TESTMTCH(DIEN,RIEN,NLINES) ;
  1.  ;validate if finding item and Result Group finding item match
  1.  N DNAME,DTEST,RNAME,RTEST,RESULT,TEXT
  1.  S DTEST=+$P($G(^PXRMD(801.41,DIEN,1)),U,5)
  1.  S RTEST=+$P($G(^PXRMD(801.41,RIEN,50)),U)
  1.  S RESULT=$S(DTEST=0:0,RTEST=0:0,DTEST'=RTEST:0,1:1)
  1.  I RESULT=1 Q RESULT
  1.  S DNAME=$P($G(^PXRMD(801.41,DIEN,0)),U)
  1.  ;Release with Exchange no reason to print error, entry already updated
  1.  I DNAME="VA-MH DOMG" Q 0
  1.  S RNAME=$P($G(^PXRMD(801.41,RIEN,0)),U)
  1.  S TEXT="Result Group: "_RNAME_" could not be moved for the following"
  1.  S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=TEXT
  1.  S TEXT="element "_DNAME_"."
  1.  S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=TEXT
  1.  S TEXT="Manual Correction is needed."
  1.  S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=TEXT
  1.  S NLINES=NLINES+1,^TMP("PXRMXMZ",$J,NLINES,0)=""
  1.  ;D BMES^XPDUTL(.TEXT)
  1.  Q RESULT
  1.  ;
  1. WRITERG ;
  1.  ;write RG from XTMP back to file 801.41
  1.  N CNT,DA,DIE,DR,FDA,NLINES,PXRMXTMP,RGIEN,TEXT
  1.  S NLINES=0
  1.  K ^TMP("PXRMXMZ",$J)
  1.  S TEXT(1)="Moving Result Group to new multiple location."
  1.  S TEXT(2)="See MailMan message for any error."
  1.  D BMES^XPDUTL(.TEXT)
  1.  S PXRMXTMP="PXRM PATCH 6"
  1.  I $D(^XTMP(PXRMXTMP,"PXRM DCONV"))=0 Q
  1.  S CNT=0 F  S CNT=$O(^XTMP(PXRMXTMP,"PXRM DCONV",CNT)) Q:CNT'>0  D
  1.  .S DA=$P($G(^XTMP(PXRMXTMP,"PXRM DCONV",CNT)),U)
  1.  .S RGIEN=$P($G(^XTMP(PXRMXTMP,"PXRM DCONV",CNT)),U,2)
  1.  .I $$TESTMTCH(DA,RGIEN,.NLINES)=0 Q
  1.  .S DA(1)=DA
  1.  .S FDA(801.41121,"+1,"_DA(1)_",",.01)=RGIEN
  1.  .D UPDATE^DIE("","FDA","","MSG")
  1.  .I $D(MSG)>0 D AWRITE^PXRMUTIL("MSG") H 1
  1.  S TEXT="Result Groups that could not be moved."
  1.  I NLINES>0 D SEND^PXRMMSG(TEXT)
  1.  K ^XTMP(PXRMXTMP)
  1.  K ^TMP("PXRMXMZ",$J)
  1.  Q