source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m@ 628

PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;08/16/2007
 ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
 ;
 ;==================================================
 ;
 ;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,"PXRMDNAM"))
 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(IND,1)
 ;
 ;Clear lock
 D UNLOCK
 ;
 ;Rebuild display workfile
 D DISP^PXRMEXLD(PXRMMODE)
 ;
 K PXRMNMCH
 Q
 ;
 ;Build list of descendents names
 ;-------------------------------
INSBLD(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^PXRMEXD1(NAME) I REPL>0 D INSREPL(NAME,REPL,.INAME)
 .S INAME(DNAME)=""
 .;Q:$$PXRM(DNAME)  S INAME(DNAME)=""
 .;Check for descendants
 .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
 Q
 ;Build list of replacement names
 ;-------------------------------
INSREPL(NAME,REPL,INAME) ;
 N DNAME,IDATA,ISEQ
 S ISEQ=0
 S IDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",REPL,NAME)) Q:IDATA=""
 S DNAME=$P(IDATA,U) Q:DNAME=""  S INAME(DNAME)=""
 ;S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
 ;Check for descendants
 I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
 Q
 ;
 ;Install component IND
 ;---------------------
INSCOM(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 EXISTS=$P(TEMP,U,4),START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
 S JND120=$P(TEMP,U,6) Q:'JND120
 S IND120=$P(TEMP,U,5) Q:'IND120
 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^PXRMEXD1(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(PT01,REPL,.INAME)
 ..;Build list of decendents to install
 ..D INSBLD(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(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)
 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
 .;I '$$PXRM($P(DATA,U)) 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="DISABLED IN EXCHANGE"
 ;Except for National dialogs
 I $P(^PXRMD(801.41,DIEN,100),U)="N" S DISABLE=""
 ;
 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=""
 ;If reminder was renamed use as default
 I $D(PXRMNMCH(811.9)) D
 .S RNAME=$O(PXRMNMCH(811.9,"")) Q:RNAME=""
 .S RNAME=$G(PXRMNMCH(811.9,RNAME))
 ;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
 ..S RIEN=$P(DATA,U,4),FOUND=1 Q:'RIEN
 ..S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
 ;
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,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 IND=0
 F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,0)
 ;
 ;Clear locks
 D UNLOCK
 ;
 ;Rebuild workfile
 D DISP^PXRMEXLD(PXRMMODE)
 Q
 ;
 ;Install the exchange entry PXRMRIEN
 ;-----------------------------------
INSTALL N IEN,IND,VALMY
 ;Make sure the component list exists for this entry. PXRMRIEN is
 ;set in INSTALL^PXRMEXLR.
 I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
 I PXRMRIEN=-1 Q
 ;Format the component list for display.
 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):0 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