source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMP6ID.m@ 1397

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