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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMP6ID 4916 printed Apr 09, 2024@20:52:50 Page 2
PXRMP6ID ; SLC/AGP - Inits for PXRM*2.0*6 ;11/25/2007
+1 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+2 ;
+3 QUIT
+4 ;====================================================
BDICONV ;
+1 NEW BDI,BDI2,DA,DIE,DR,ITEM,NAME,NLINES,RGBDI,RGBDI2,TEXT
+2 KILL ^TMP("PXRMXMZ",$JOB)
+3 SET TEXT(1)="Converting Dialog Elements from BDI to BDI2."
+4 SET TEXT(2)="See Mailman message for more details."
+5 DO MES^XPDUTL(.TEXT)
+6 SET NLINES=1
SET TEXT="Dialog Elements names that were converted."
+7 SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=TEXT
+8 SET DIE="^PXRMD(801.41,"
+9 SET BDI=$ORDER(^YTT(601,"B","BDI",""))
if BDI'>0
QUIT
+10 SET BDI2=$ORDER(^YTT(601,"B","BDI2",""))
if BDI2'>0
QUIT
+11 SET BDI=BDI_";YTT(601,"
SET BDI2=BDI2_";YTT(601,"
+12 SET RGBDI=$ORDER(^PXRMD(801.41,"B","PXRM BDI RESULT GROUP",""))
if RGBDI'>0
QUIT
+13 SET RGBDI2=$ORDER(^PXRMD(801.41,"B","PXRM BDI II RESULT GROUP",""))
if RGBDI2'>0
QUIT
+14 SET DA=0
FOR
SET DA=$ORDER(^PXRMD(801.41,DA))
if DA'>0
QUIT
Begin DoDot:1
+15 SET ITEM=$PIECE($GET(^PXRMD(801.41,DA,1)),U,5)
if ITEM'>0
QUIT
+16 IF BDI=ITEM
Begin DoDot:2
+17 SET NAME=$PIECE($GET(^PXRMD(801.41,DA,0)),U)
+18 SET DR="15////^S X=BDI2"
+19 IF $PIECE($GET(^PXRMD(801.41,DA,0)),U,15)=RGBDI
Begin DoDot:3
+20 SET DR=DR_";55////^S X=RGBDI2"
DO ^DIE
End DoDot:3
+21 DO ^DIE
+22 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=NAME
End DoDot:2
End DoDot:1
+23 IF NLINES=1
Begin DoDot:1
+24 SET NLINES=NLINES+1
+25 SET ^TMP("PXRMXMZ",$JOB,NLINES,0)="No dialog elements were converted."
End DoDot:1
+26 DO SEND^PXRMMSG("Dialog elements converted from BDI to BDI2")
+27 KILL ^TMP("PXRMXMZ",$JOB)
+28 QUIT
CHECKRG ;
+1 ;list non-National Result Groups that need to be mapped to a MH finding
+2 NEW DIEN,NLINES,NODE,TEXT
+3 KILL ^TMP("PXRMXMZ",$JOB)
+4 SET NLINES=0
+5 SET DIEN=0
FOR
SET DIEN=$ORDER(^PXRMD(801.41,DIEN))
if DIEN'>0
QUIT
Begin DoDot:1
+6 SET NODE=$GET(^PXRMD(801.41,DIEN,0))
+7 IF $PIECE(NODE,U,4)'="S"
QUIT
+8 IF $PIECE($GET(^PXRMD(801.41,DIEN,100)),U)="N"
QUIT
+9 SET TEXT="Result Group: "_$PIECE(NODE,U)_" needs to be mapped to an MH test and scale."
+10 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=TEXT
+11 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=""
End DoDot:1
+12 SET TEXT="Dialog Results Groups that need to be mapped to a MH Test."
+13 IF NLINES>0
DO SEND^PXRMMSG(TEXT)
+14 KILL ^TMP("PXRMXMZ",$JOB)
+15 QUIT
+16 ;
DCLEAN ;
+1 NEW CNT,DA,DIEN,DIK,EARRAY,EIEN,RIEN,TEXT
+2 SET RIEN=$ORDER(^PXD(811.9,"B","PXRM RESULT GROUP UPDATE REMINDER",""))
+3 if RIEN'>0
QUIT
+4 SET DIEN=$PIECE($GET(^PXD(811.9,RIEN,51)),U)
if DIEN'>0
QUIT
+5 SET TEXT="Removing transport reminder and dialog for Result Groups."
+6 DO MES^XPDUTL(.TEXT)
+7 SET CNT=0
FOR
SET CNT=$ORDER(^PXRMD(801.41,DIEN,10,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+8 SET EIEN=$PIECE($GET(^PXRMD(801.41,DIEN,10,CNT,0)),U,2)
+9 IF $PIECE($PIECE($GET(^PXRMD(801.41,EIEN,0)),U)," ")'="PXRM"
QUIT
+10 SET EARRAY(EIEN)=""
End DoDot:1
+11 SET DIK="^PXRMD(801.41,"
+12 SET DA=""
FOR
SET DA=$ORDER(EARRAY(DA))
if DA'>0
QUIT
DO ^DIK
+13 SET DA=DIEN
DO ^DIK
+14 SET DIK="^PXD(811.9,"
SET DA=RIEN
DO ^DIK
+15 QUIT
+16 ;
REINDEX ;
+1 SET DIK="^PXRMD(801.41,"
SET DIK(1)=4
DO ENALL^DIK
+2 QUIT
STORERG ;
+1 ;store result groups for an element in XTMP
+2 NEW CNT,DIEN,RGIEN,PXRMXTMP,TYPE
+3 ;S PXRMXTMP="PXRM"_$$NOW^XLFDT
+4 SET PXRMXTMP="PXRM PATCH 6"
+5 KILL ^XTMP(PXRMXTMP)
+6 SET ^XTMP(PXRMXTMP,0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"PXRM PATCH 6 DIALOG CONVERSION"
+7 SET DIEN=0
SET CNT=0
FOR
SET DIEN=$ORDER(^PXRMD(801.41,DIEN))
if DIEN'>0
QUIT
Begin DoDot:1
+8 SET TYPE=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)
+9 IF TYPE'="E"
IF TYPE'="G"
QUIT
+10 IF $PIECE($GET(^PXRMD(801.41,DIEN,0)),U,15)=""
QUIT
+11 SET CNT=CNT+1
+12 SET ^XTMP(PXRMXTMP,"PXRM DCONV",CNT)=DIEN_U_+$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,15)
+13 SET $PIECE(^PXRMD(801.41,DIEN,0),U,15)=""
End DoDot:1
+14 QUIT
+15 ;
TESTMTCH(DIEN,RIEN,NLINES) ;
+1 ;validate if finding item and Result Group finding item match
+2 NEW DNAME,DTEST,RNAME,RTEST,RESULT,TEXT
+3 SET DTEST=+$PIECE($GET(^PXRMD(801.41,DIEN,1)),U,5)
+4 SET RTEST=+$PIECE($GET(^PXRMD(801.41,RIEN,50)),U)
+5 SET RESULT=$SELECT(DTEST=0:0,RTEST=0:0,DTEST'=RTEST:0,1:1)
+6 IF RESULT=1
QUIT RESULT
+7 SET DNAME=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U)
+8 ;Release with Exchange no reason to print error, entry already updated
+9 IF DNAME="VA-MH DOMG"
QUIT 0
+10 SET RNAME=$PIECE($GET(^PXRMD(801.41,RIEN,0)),U)
+11 SET TEXT="Result Group: "_RNAME_" could not be moved for the following"
+12 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=TEXT
+13 SET TEXT="element "_DNAME_"."
+14 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=TEXT
+15 SET TEXT="Manual Correction is needed."
+16 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=TEXT
+17 SET NLINES=NLINES+1
SET ^TMP("PXRMXMZ",$JOB,NLINES,0)=""
+18 ;D BMES^XPDUTL(.TEXT)
+19 QUIT RESULT
+20 ;
WRITERG ;
+1 ;write RG from XTMP back to file 801.41
+2 NEW CNT,DA,DIE,DR,FDA,NLINES,PXRMXTMP,RGIEN,TEXT
+3 SET NLINES=0
+4 KILL ^TMP("PXRMXMZ",$JOB)
+5 SET TEXT(1)="Moving Result Group to new multiple location."
+6 SET TEXT(2)="See MailMan message for any error."
+7 DO BMES^XPDUTL(.TEXT)
+8 SET PXRMXTMP="PXRM PATCH 6"
+9 IF $DATA(^XTMP(PXRMXTMP,"PXRM DCONV"))=0
QUIT
+10 SET CNT=0
FOR
SET CNT=$ORDER(^XTMP(PXRMXTMP,"PXRM DCONV",CNT))
if CNT'>0
QUIT
Begin DoDot:1
+11 SET DA=$PIECE($GET(^XTMP(PXRMXTMP,"PXRM DCONV",CNT)),U)
+12 SET RGIEN=$PIECE($GET(^XTMP(PXRMXTMP,"PXRM DCONV",CNT)),U,2)
+13 IF $$TESTMTCH(DA,RGIEN,.NLINES)=0
QUIT
+14 SET DA(1)=DA
+15 SET FDA(801.41121,"+1,"_DA(1)_",",.01)=RGIEN
+16 DO UPDATE^DIE("","FDA","","MSG")
+17 IF $DATA(MSG)>0
DO AWRITE^PXRMUTIL("MSG")
HANG 1
End DoDot:1
+18 SET TEXT="Result Groups that could not be moved."
+19 IF NLINES>0
DO SEND^PXRMMSG(TEXT)
+20 KILL ^XTMP(PXRMXTMP)
+21 KILL ^TMP("PXRMXMZ",$JOB)
+22 QUIT
