- 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 Feb 18, 2025@23:11:21 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