PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine. ;09/08/2015 09:21
;;2.0;CLINICAL REMINDERS;**6,12,24,26,45**;Feb 04, 2005;Build 566
;
;==================================================
;Install all dialog components in an exchange file entry
;------------------------------------------------
INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
;
;Set the install date and time.
S IND="",PXRMDONE=0
;
;Go to full screen mode.
D FULL^VALM1
;
;Check if all or none exists - option to install all unchanged
N DNAME
S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAME"))
D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
I ALL=0 D DISP^PXRMEXLD(PXRMMODE) Q
;
;Lock the entire file
Q:'$$LOCK
F S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE) D
.D INSCOM(DNAME,IND,1)
;
;Clear lock
D UNLOCK
;
;Rebuild display workfile
D DISP^PXRMEXLD(PXRMMODE)
;
K PXRMNMCH
Q
;
;Build list of descendents names
;-------------------------------
INSBLD(DIALNAM,NAME,INAME) ;
N DNAME,IDATA,ISEQ
S ISEQ=0
F S ISEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:'ISEQ D
.S IDATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:IDATA=""
.S DNAME=$P(IDATA,U) Q:DNAME=""
.;
.I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D
..S REPL=$$CHKREPL^PXRMEXDB(DIALNAM,NAME) I REPL>0 D INSREPL(DIALNAM,NAME,REPL,.INAME)
.S INAME(DNAME)=""
.;Check for descendants
.I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DIALNAM,DNAME,.INAME)
Q
;
;Build list of replacement names
;-------------------------------
INSREPL(DIALNAME,NAME,REPL,INAME) ;
N DNAME,IDATA,ISEQ
S ISEQ=0
S IDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",DIALNAM,REPL,NAME)) Q:IDATA=""
S DNAME=$P(IDATA,U) Q:DNAME="" S INAME(DNAME)=""
;Check for descendants
I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DIALNAM,DNAME,.INAME)
Q
;
;Install component IND
;---------------------
INSCOM(DIALNAM,IND,SILENT) ;
N ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
N NEWPT01,PT01,START,REPL,SAME,TEMP
S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),FILENUM=$P(TEMP,U,1)
S START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
S IND120=$P(TEMP,U,4) Q:'IND120
S JND120=$P(TEMP,U,5) Q:'JND120
S EXISTS=$P(TEMP,U,6)
S TEMP=^PXD(811.8,PXRMRIEN,100,START,0),PT01=$P(TEMP,"~",2) Q:PT01=""
S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",PT01))
I DTYP="dialog" S DTYP="reminder dialog"
;
;Go to full screen mode.
D FULL^VALM1
;
;Check for descendents
S REPL=$$CHKREPL^PXRMEXDB(DIALNAM,PT01)
I 'SILENT&($$INSDSC(PT01)!(REPL>0)) D Q:PXRMDONE
.N ANS,INDS,TEXT
.S TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
.S TEXT="Install all sub-components with the "_DTYP_": "
.;Give option to install all descendents
.D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE
.I $G(ANS)="N" S PXRMDONE=1 Q
.I $G(ANS)="Y" D
..S INDS=IND
..N IDATA,INAME,IND
..I REPL>0 D INSREPL(DIALNAM,PT01,REPL,.INAME)
..;Build list of decendents to install
..D INSBLD(DIALNAM,PT01,.INAME)
..;Check if all or none exists - option to install all unchanged
..D EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME) Q:PXRMDONE
..;Start at the end of the list
..S IND=""
..F S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:PXRMDONE!(IND=INDS) D
...N PT01,START,TEMP
...S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),START=$P(TEMP,U,2) Q:START=""
...S PT01=$P(^PXD(811.8,PXRMRIEN,100,START,0),"~",2) Q:PT01=""
...;Ignore namechanges
...I $D(PXRMNMCH(801.41,PT01)) Q
...;Only install descendents
...I $D(INAME(PT01)) D INSCOM(DIALNAM,IND,1)
;
SETENTRY ;
D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
S ACTION=""
;Double check that it hasn't been installed
S EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
I EXIEN,'EXISTS S EXISTS=1
I EXISTS D
. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
. S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXIEN)
. S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
. I SAME D FEIMSG^PXRMEXFI(SAME,.ATTR) S ACTION="S",(PXRMNMCH,NEWPT01)=""
I ACTION="" D
.;If all components installed the default is 'Install or Overwrite'
. S:ALL ACTION=$S(EXISTS:"O",1:"I"),(PXRMNMCH,NEWPT01)=""
. S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXIEN)
;Save what was done for the installation summary.
S ^TMP("PXRMEXIAD",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
;Clear heading
S VALMHDR(2)=""
;If the ACTION is Quit then quit the entire install.
I ACTION="Q" S PXRMDONE=1 S VALMHDR(2)="Install not completed" Q
;If the ACTION is Skip then skip this component.
I ACTION="S" S VALMBCK="R" Q
;If the ACTION is Replace then skip this component.
I ACTION="P" S VALMBCK="R",VALMHDR(2)=PT01_" replaced with "_NEWPT01 Q
;Install this component.
D FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
S VALMBCK="R"
I PXRMDONE S VALMHDR(2)="Install aborted" Q
I NEWPT01="" S VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file."
I NEWPT01'="" S VALMHDR(2)=PT01_" installed as "_NEWPT01_"."
;If reminder dialog - disable and give option to link
I DTYP="reminder dialog" D
.N DNAME
.S DNAME=PT01
.I NEWPT01'="" S DNAME=NEWPT01
.D INSLNK(DNAME)
.I $D(^TMP("PXRM DIALOG LINK FILE",$J))>0 D DLINKSET^PXRMEXU5
Q
;
;Check for descendents (either elements or prompts)
;--------------------------------------------------
INSDSC(NAME) ;
N DATA,DFOUND,SUB
S DFOUND=0,SUB=0
F S SUB=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:'SUB D Q:DFOUND
.S DATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:DATA=""
.S DFOUND=1
Q DFOUND
;
INSREPL1(NAME) ;
N DATA,DFOUND,SUB
S DFOUND=0,SUB=0
F S SUB=$O(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:'SUB D Q:DFOUND
.S DATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:DATA=""
.S DFOUND=1
Q DFOUND
;Option to link dialog to a reminder
;-----------------------------------
INSLNK(DNAME) ;
N DIEN,DISABLE,DSRC,RNAME
N DA,DIE,DR
;Disable
S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:'DIEN
;Set dialog as disabled
S DISABLE=1
;Except for National dialogs
I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE=0
;
S DR="3///^S X=DISABLE",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
D ^DIE
;
;Quit if already linked
I $D(^PXD(811.9,"AG",DIEN)) Q
;
S RNAME=$O(^TMP("PXRMEXDL",$J,DNAME,""))
;
;Otherwise use original reminder name as default
I RNAME="" D
.N DATA,FOUND,RIEN,SUB
.;Rebuild ^TMP("PXRMEXLC",$J
.D CDISP^PXRMEXLC(PXRMRIEN)
.;
.S SUB="",FOUND=0
.F S SUB=$O(^TMP("PXRMEXLC",$J,"SEL",SUB),-1) Q:'SUB Q:FOUND D
..S DATA=$G(^TMP("PXRMEXLC",$J,"SEL",SUB)) Q:$P(DATA,U)'=811.9
;
I RNAME="" Q
TAG W !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",!
;Select reminder to link
S IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME)
;Update reminder link in #811.9
I $P(IEN,U)'=-1 D
.N DA,DIE,DIK,DR
.;Set reminder to dialog pointer
.S DR="51///^S X=DNAME",DIE="^PXD(811.9,",DA=$P(IEN,U)
.D ^DIE
.;If source reminder is null replace with linked reminder
.S DSRC=$P($G(^PXRMD(801.41,DIEN,0)),U,2) Q:DSRC
.S DSRC=$P(IEN,U)
.S DR="2///^S X=DSRC",DIE="^PXRMD(801.41,",DA=$P(DIEN,U)
.D ^DIE
Q
;
;Install Selected Components
;---------------------------
INSSEL N ALL,IND,PXRMDONE,VALMY
N DIROUT,DIRUT,DNAME,DTOUT,DUOUT
N VALMBG,VALMLST
S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXLD",$J,"IDX",""),-1)
;Get the list to install.
D EN^VALM2(XQORNOD(0))
;
;Set the install date and time.
S ALL="",PXRMDONE=0
;
;Lock the entire file
Q:'$$LOCK
;
S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAME"))
S IND=0
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D INSCOM(DNAME,IND,0)
;
;Clear locks
D UNLOCK
;
;Rebuild workfile
D DISP^PXRMEXLD(PXRMMODE)
Q
;
;Install the exchange entry PXRMRIEN
;-----------------------------------
INSTALL N CLOK,IEN,IND,VALMY
;Make sure the component list exists for this entry. PXRMRIEN is
;set in INSTALL^PXRMEXLR.
S CLOK=1
I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXCO(PXRMRIEN,.CLOK)
I 'CLOK Q
D CDISP^PXRMEXLC(PXRMRIEN)
S VALMBCK="R",VALMCNT=$O(^TMP("PXRMEXLD",$J,"IDX"),-1)
Q
;
PXRM(NAME) ;Validate prompts
;Ignore non-PXRM
I $E(NAME,1,4)'="PXRM" Q 0
N DIEN,RESULT
I $G(PXRMINST)=1 D Q RESULT
.S RESULT=0
.S DIEN=$O(^PXRMD(801.41,"B",NAME,"")) I 'DIEN Q
.I $P($G(^PXRMD(801.41,DIEN,100)),U)'="N" Q
.I ($P($G(^PXRMD(801.41,DIEN,0)),U,4)="P")!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="F") S RESULT=1
;
;Check if this is a national code
S DIEN=$O(^PXRMD(801.41,"B",NAME,""))
;If not found abort
I 'DIEN Q 0
;if result group/element quit
I $P($G(^PXRMD(801.41,DIEN,0)),U,4)="S"!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="T") Q 0
;Check class
I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1
;Otherwise local
Q 0
;
;Lock the dialog file
LOCK() ;
L +^PXRMD(801.41):DILOCKTM I Q 1
E W !,"Another user is editing this file, try later" H 2
Q 0
;
;Clear lock
UNLOCK L -^PXRMD(801.41)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMEXID 8966 printed Nov 22, 2024@16:55:10 Page 2
PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine. ;09/08/2015 09:21
+1 ;;2.0;CLINICAL REMINDERS;**6,12,24,26,45**;Feb 04, 2005;Build 566
+2 ;
+3 ;==================================================
+4 ;Install all dialog components in an exchange file entry
+5 ;------------------------------------------------
INSALL NEW ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
+1 ;
+2 ;Set the install date and time.
+3 SET IND=""
SET PXRMDONE=0
+4 ;
+5 ;Go to full screen mode.
+6 DO FULL^VALM1
+7 ;
+8 ;Check if all or none exists - option to install all unchanged
+9 NEW DNAME
+10 SET DNAME=$GET(^TMP("PXRMEXTMP",$JOB,"PXRMDNAME"))
+11 DO EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
+12 IF ALL=0
DO DISP^PXRMEXLD(PXRMMODE)
QUIT
+13 ;
+14 ;Lock the entire file
+15 if '$$LOCK
QUIT
+16 FOR
SET IND=$ORDER(^TMP("PXRMEXLD",$JOB,"SEL",IND),-1)
if (IND="")!(PXRMDONE)
QUIT
Begin DoDot:1
+17 DO INSCOM(DNAME,IND,1)
End DoDot:1
+18 ;
+19 ;Clear lock
+20 DO UNLOCK
+21 ;
+22 ;Rebuild display workfile
+23 DO DISP^PXRMEXLD(PXRMMODE)
+24 ;
+25 KILL PXRMNMCH
+26 QUIT
+27 ;
+28 ;Build list of descendents names
+29 ;-------------------------------
INSBLD(DIALNAM,NAME,INAME) ;
+1 NEW DNAME,IDATA,ISEQ
+2 SET ISEQ=0
+3 FOR
SET ISEQ=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",NAME,ISEQ))
if 'ISEQ
QUIT
Begin DoDot:1
+4 SET IDATA=$GET(^TMP("PXRMEXTMP",$JOB,"DMAP",NAME,ISEQ))
if IDATA=""
QUIT
+5 SET DNAME=$PIECE(IDATA,U)
if DNAME=""
QUIT
+6 ;
+7 IF $DATA(^TMP("PXRMEXTMP",$JOB,"DREPL"))>0
Begin DoDot:2
+8 SET REPL=$$CHKREPL^PXRMEXDB(DIALNAM,NAME)
IF REPL>0
DO INSREPL(DIALNAM,NAME,REPL,.INAME)
End DoDot:2
+9 SET INAME(DNAME)=""
+10 ;Check for descendants
+11 IF $DATA(^TMP("PXRMEXTMP",$JOB,"DMAP",DNAME))
DO INSBLD(DIALNAM,DNAME,.INAME)
End DoDot:1
+12 QUIT
+13 ;
+14 ;Build list of replacement names
+15 ;-------------------------------
INSREPL(DIALNAME,NAME,REPL,INAME) ;
+1 NEW DNAME,IDATA,ISEQ
+2 SET ISEQ=0
+3 SET IDATA=$GET(^TMP("PXRMEXTMP",$JOB,"DREPL",DIALNAM,REPL,NAME))
if IDATA=""
QUIT
+4 SET DNAME=$PIECE(IDATA,U)
if DNAME=""
QUIT
SET INAME(DNAME)=""
+5 ;Check for descendants
+6 IF $DATA(^TMP("PXRMEXTMP",$JOB,"DMAP",DNAME))
DO INSBLD(DIALNAM,DNAME,.INAME)
+7 QUIT
+8 ;
+9 ;Install component IND
+10 ;---------------------
INSCOM(DIALNAM,IND,SILENT) ;
+1 NEW ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
+2 NEW NEWPT01,PT01,START,REPL,SAME,TEMP
+3 SET TEMP=^TMP("PXRMEXLD",$JOB,"SEL",IND)
SET FILENUM=$PIECE(TEMP,U,1)
+4 SET START=$PIECE(TEMP,U,2)
SET END=$PIECE(TEMP,U,3)
if START=""
QUIT
+5 SET IND120=$PIECE(TEMP,U,4)
if 'IND120
QUIT
+6 SET JND120=$PIECE(TEMP,U,5)
if 'JND120
QUIT
+7 SET EXISTS=$PIECE(TEMP,U,6)
+8 SET TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
SET PT01=$PIECE(TEMP,"~",2)
if PT01=""
QUIT
+9 SET DTYP=$GET(^TMP("PXRMEXTMP",$JOB,"DTYP",PT01))
+10 IF DTYP="dialog"
SET DTYP="reminder dialog"
+11 ;
+12 ;Go to full screen mode.
+13 DO FULL^VALM1
+14 ;
+15 ;Check for descendents
+16 SET REPL=$$CHKREPL^PXRMEXDB(DIALNAM,PT01)
+17 IF 'SILENT&($$INSDSC(PT01)!(REPL>0))
Begin DoDot:1
+18 NEW ANS,INDS,TEXT
+19 SET TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
+20 SET TEXT="Install all sub-components with the "_DTYP_": "
+21 ;Give option to install all descendents
+22 DO ASK^PXRMEXIX(.ANS,.TEXT,1)
if PXRMDONE
QUIT
+23 IF $GET(ANS)="N"
SET PXRMDONE=1
QUIT
+24 IF $GET(ANS)="Y"
Begin DoDot:2
+25 SET INDS=IND
+26 NEW IDATA,INAME,IND
+27 IF REPL>0
DO INSREPL(DIALNAM,PT01,REPL,.INAME)
+28 ;Build list of decendents to install
+29 DO INSBLD(DIALNAM,PT01,.INAME)
+30 ;Check if all or none exists - option to install all unchanged
+31 DO EXIST^PXRMEXIX(.ALL,PT01,DTYP,.INAME)
if PXRMDONE
QUIT
+32 ;Start at the end of the list
+33 SET IND=""
+34 FOR
SET IND=$ORDER(^TMP("PXRMEXLD",$JOB,"SEL",IND),-1)
if PXRMDONE!(IND=INDS)
QUIT
Begin DoDot:3
+35 NEW PT01,START,TEMP
+36 SET TEMP=^TMP("PXRMEXLD",$JOB,"SEL",IND)
SET START=$PIECE(TEMP,U,2)
if START=""
QUIT
+37 SET PT01=$PIECE(^PXD(811.8,PXRMRIEN,100,START,0),"~",2)
if PT01=""
QUIT
+38 ;Ignore namechanges
+39 IF $DATA(PXRMNMCH(801.41,PT01))
QUIT
+40 ;Only install descendents
+41 IF $DATA(INAME(PT01))
DO INSCOM(DIALNAM,IND,1)
End DoDot:3
End DoDot:2
End DoDot:1
if PXRMDONE
QUIT
+42 ;
SETENTRY ;
+1 DO SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
+2 SET ACTION=""
+3 ;Double check that it hasn't been installed
+4 SET EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
+5 IF EXIEN
IF 'EXISTS
SET EXISTS=1
+6 IF EXISTS
Begin DoDot:1
+7 DO CHECKSUM^PXRMEXCS(.ATTR,START,END)
+8 SET CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXIEN)
+9 SET SAME=$SELECT(ATTR("CHECKSUM")=CSUM:1,1:0)
+10 IF SAME
DO FEIMSG^PXRMEXFI(SAME,.ATTR)
SET ACTION="S"
SET (PXRMNMCH,NEWPT01)=""
End DoDot:1
+11 IF ACTION=""
Begin DoDot:1
+12 ;If all components installed the default is 'Install or Overwrite'
+13 if ALL
SET ACTION=$SELECT(EXISTS:"O",1:"I")
SET (PXRMNMCH,NEWPT01)=""
+14 if 'ALL
SET ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXIEN)
End DoDot:1
+15 ;Save what was done for the installation summary.
+16 SET ^TMP("PXRMEXIAD",$JOB,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
+17 ;Clear heading
+18 SET VALMHDR(2)=""
+19 ;If the ACTION is Quit then quit the entire install.
+20 IF ACTION="Q"
SET PXRMDONE=1
SET VALMHDR(2)="Install not completed"
QUIT
+21 ;If the ACTION is Skip then skip this component.
+22 IF ACTION="S"
SET VALMBCK="R"
QUIT
+23 ;If the ACTION is Replace then skip this component.
+24 IF ACTION="P"
SET VALMBCK="R"
SET VALMHDR(2)=PT01_" replaced with "_NEWPT01
QUIT
+25 ;Install this component.
+26 DO FILE^PXRMEXIC(PXRMRIEN,EXIEN,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+27 SET VALMBCK="R"
+28 IF PXRMDONE
SET VALMHDR(2)="Install aborted"
QUIT
+29 IF NEWPT01=""
SET VALMHDR(2)=PT01_" ("_DTYP_") installed from exchange file."
+30 IF NEWPT01'=""
SET VALMHDR(2)=PT01_" installed as "_NEWPT01_"."
+31 ;If reminder dialog - disable and give option to link
+32 IF DTYP="reminder dialog"
Begin DoDot:1
+33 NEW DNAME
+34 SET DNAME=PT01
+35 IF NEWPT01'=""
SET DNAME=NEWPT01
+36 DO INSLNK(DNAME)
+37 IF $DATA(^TMP("PXRM DIALOG LINK FILE",$JOB))>0
DO DLINKSET^PXRMEXU5
End DoDot:1
+38 QUIT
+39 ;
+40 ;Check for descendents (either elements or prompts)
+41 ;--------------------------------------------------
INSDSC(NAME) ;
+1 NEW DATA,DFOUND,SUB
+2 SET DFOUND=0
SET SUB=0
+3 FOR
SET SUB=$ORDER(^TMP("PXRMEXTMP",$JOB,"DMAP",NAME,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^TMP("PXRMEXTMP",$JOB,"DMAP",NAME,SUB))
if DATA=""
QUIT
+5 SET DFOUND=1
End DoDot:1
if DFOUND
QUIT
+6 QUIT DFOUND
+7 ;
INSREPL1(NAME) ;
+1 NEW DATA,DFOUND,SUB
+2 SET DFOUND=0
SET SUB=0
+3 FOR
SET SUB=$ORDER(^TMP("PXRMEXTMP",$JOB,"DREPL",NAME,SUB))
if 'SUB
QUIT
Begin DoDot:1
+4 SET DATA=$GET(^TMP("PXRMEXTMP",$JOB,"DREPL",NAME,SUB))
if DATA=""
QUIT
+5 SET DFOUND=1
End DoDot:1
if DFOUND
QUIT
+6 QUIT DFOUND
+7 ;Option to link dialog to a reminder
+8 ;-----------------------------------
INSLNK(DNAME) ;
+1 NEW DIEN,DISABLE,DSRC,RNAME
+2 NEW DA,DIE,DR
+3 ;Disable
+4 SET DIEN=$ORDER(^PXRMD(801.41,"B",DNAME,""))
if 'DIEN
QUIT
+5 ;Set dialog as disabled
+6 SET DISABLE=1
+7 ;Except for National dialogs
+8 IF $PIECE(^PXRMD(801.41,DIEN,100),U)="N"
SET DISABLE=0
+9 ;
+10 SET DR="3///^S X=DISABLE"
SET DIE="^PXRMD(801.41,"
SET DA=$PIECE(DIEN,U)
+11 DO ^DIE
+12 ;
+13 ;Quit if already linked
+14 IF $DATA(^PXD(811.9,"AG",DIEN))
QUIT
+15 ;
+16 SET RNAME=$ORDER(^TMP("PXRMEXDL",$JOB,DNAME,""))
+17 ;
+18 ;Otherwise use original reminder name as default
+19 IF RNAME=""
Begin DoDot:1
+20 NEW DATA,FOUND,RIEN,SUB
+21 ;Rebuild ^TMP("PXRMEXLC",$J
+22 DO CDISP^PXRMEXLC(PXRMRIEN)
+23 ;
+24 SET SUB=""
SET FOUND=0
+25 FOR
SET SUB=$ORDER(^TMP("PXRMEXLC",$JOB,"SEL",SUB),-1)
if 'SUB
QUIT
if FOUND
QUIT
Begin DoDot:2
+26 SET DATA=$GET(^TMP("PXRMEXLC",$JOB,"SEL",SUB))
if $PIECE(DATA,U)'=811.9
QUIT
End DoDot:2
End DoDot:1
+27 ;
+28 IF RNAME=""
QUIT
TAG WRITE !!,"Reminder Dialog "_DNAME_" is not linked to a reminder.",!
+1 ;Select reminder to link
+2 SET IEN=$$SELECT^PXRMINQ("^PXD(811.9,","Select Reminder to Link: ",RNAME)
+3 ;Update reminder link in #811.9
+4 IF $PIECE(IEN,U)'=-1
Begin DoDot:1
+5 NEW DA,DIE,DIK,DR
+6 ;Set reminder to dialog pointer
+7 SET DR="51///^S X=DNAME"
SET DIE="^PXD(811.9,"
SET DA=$PIECE(IEN,U)
+8 DO ^DIE
+9 ;If source reminder is null replace with linked reminder
+10 SET DSRC=$PIECE($GET(^PXRMD(801.41,DIEN,0)),U,2)
if DSRC
QUIT
+11 SET DSRC=$PIECE(IEN,U)
+12 SET DR="2///^S X=DSRC"
SET DIE="^PXRMD(801.41,"
SET DA=$PIECE(DIEN,U)
+13 DO ^DIE
End DoDot:1
+14 QUIT
+15 ;
+16 ;Install Selected Components
+17 ;---------------------------
INSSEL NEW ALL,IND,PXRMDONE,VALMY
+1 NEW DIROUT,DIRUT,DNAME,DTOUT,DUOUT
+2 NEW VALMBG,VALMLST
+3 SET VALMBG=1
SET VALMLST=+$ORDER(^TMP("PXRMEXLD",$JOB,"IDX",""),-1)
+4 ;Get the list to install.
+5 DO EN^VALM2(XQORNOD(0))
+6 ;
+7 ;Set the install date and time.
+8 SET ALL=""
SET PXRMDONE=0
+9 ;
+10 ;Lock the entire file
+11 if '$$LOCK
QUIT
+12 ;
+13 SET DNAME=$GET(^TMP("PXRMEXTMP",$JOB,"PXRMDNAME"))
+14 SET IND=0
+15 FOR
SET IND=$ORDER(VALMY(IND))
if (+IND=0)!(PXRMDONE)
QUIT
DO INSCOM(DNAME,IND,0)
+16 ;
+17 ;Clear locks
+18 DO UNLOCK
+19 ;
+20 ;Rebuild workfile
+21 DO DISP^PXRMEXLD(PXRMMODE)
+22 QUIT
+23 ;
+24 ;Install the exchange entry PXRMRIEN
+25 ;-----------------------------------
INSTALL NEW CLOK,IEN,IND,VALMY
+1 ;Make sure the component list exists for this entry. PXRMRIEN is
+2 ;set in INSTALL^PXRMEXLR.
+3 SET CLOK=1
+4 IF '$DATA(^PXD(811.8,PXRMRIEN,120))
DO CLIST^PXRMEXCO(PXRMRIEN,.CLOK)
+5 IF 'CLOK
QUIT
+6 DO CDISP^PXRMEXLC(PXRMRIEN)
+7 SET VALMBCK="R"
SET VALMCNT=$ORDER(^TMP("PXRMEXLD",$JOB,"IDX"),-1)
+8 QUIT
+9 ;
PXRM(NAME) ;Validate prompts
+1 ;Ignore non-PXRM
+2 IF $EXTRACT(NAME,1,4)'="PXRM"
QUIT 0
+3 NEW DIEN,RESULT
+4 IF $GET(PXRMINST)=1
Begin DoDot:1
+5 SET RESULT=0
+6 SET DIEN=$ORDER(^PXRMD(801.41,"B",NAME,""))
IF 'DIEN
QUIT
+7 IF $PIECE($GET(^PXRMD(801.41,DIEN,100)),U)'="N"
QUIT
+8 IF ($PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)="P")!($PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)="F")
SET RESULT=1
End DoDot:1
QUIT RESULT
+9 ;
+10 ;Check if this is a national code
+11 SET DIEN=$ORDER(^PXRMD(801.41,"B",NAME,""))
+12 ;If not found abort
+13 IF 'DIEN
QUIT 0
+14 ;if result group/element quit
+15 IF $PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)="S"!($PIECE($GET(^PXRMD(801.41,DIEN,0)),U,4)="T")
QUIT 0
+16 ;Check class
+17 IF $PIECE($GET(^PXRMD(801.41,DIEN,100)),U)="N"
QUIT 1
+18 ;Otherwise local
+19 QUIT 0
+20 ;
+21 ;Lock the dialog file
LOCK() ;
+1 LOCK +^PXRMD(801.41):DILOCKTM
IF $TEST
QUIT 1
+2 IF '$TEST
WRITE !,"Another user is editing this file, try later"
HANG 2
+3 QUIT 0
+4 ;
+5 ;Clear lock
UNLOCK LOCK -^PXRMD(801.41)
+1 QUIT
