Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIFROMS2

DIFROMS2.m

Go to the documentation of this file.
  1. DIFROMS2 ;SFISC/DCL/TKW - INSTALL DD FROM SOURCE ARRAY ; Jul 05, 2022@09:27:23
  1. ;;22.2;VA FileMan;**3,5,14,19,21,23**;Jan 05, 2016;Build 2
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;;GFT;**11,53,1037,1053,1055**
  1. ;
  1. Q
  1. ;
  1. EN ;CALLED FROM DIFROMS
  1. ;WHERE, E.G. ^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30!(X?.N) X
  1. ;AND THEREFORE DIFRSA=^XTMP("XPDI",4861)
  1. ;^XTMP("XPDI",4861,"FIA",21489)="MSC ORDERS HL7"
  1. ;^XTMP("XPDI",4861,"FIA",21489,0)="^MSCH(21489,"
  1. ;^XTMP("XPDI",4861,"FIA",21489,0,0)=21489
  1. ; 1)="y^y^f^^n^^y^o^n" -- ^XPD(9.6,D0,4,D1,222)
  1. ; 2)="1^^0"
  1. ;^XTMP("XPDI",4861,"FIA",21489,21489)=0 0=full, 1=partial
  1. ; 21489.01)=0
  1. ;AND THEREFORE DIFRFIA=^XTMP("XPDI",4861,"FIA")
  1. I '$D(@DIFRSA) D ERR(5) Q
  1. I '$D(@DIFRFIA) D ERR(4) Q
  1. G:$G(DIFRFILE) FCHK
  1. S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE ;LOOP THRU ALL INCOMING TOP-LEVEL FILES
  1. Q
  1. ;
  1. ;
  1. FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(6) Q
  1. FILE ;
  1. N DIFR01,DIFR02,DIFRVR,DIFRFDD,DIFRQUIT
  1. S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1)) ;UPDATE DATA DICTIONARY [1S] ^ (#222.2) SEND SECURITY CODE [2S] ^ (#222.3) SEND FULL
  1. S DIFR02=$G(@DIFRFIA@(DIFRFILE,0,2))
  1. I $TR($E(DIFR01),"NY","ny")="n" D ERR(1) Q
  1. S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p" ;DIFRFDD=0 means PARTIAL DEFINITION
  1. I 'DIFRFDD,'$D(^DIC(DIFRFILE)) D ERR(7) Q
  1. I $D(^DIC(DIFRFILE,0)),$G(@DIFRFIA@(DIFRFILE,0,10))]"" X ^(10) I '$T D ERR(3) Q
  1. ;I $TR($E(@DIFRFIA@(DIFRFILE,0,5)),"NY","ny")="y",$D(^DIC(DIFRFILE)) D ERR(2) Q ;INSTALL ONLY IF NEW * * PHASING OUT * *
  1. N %1,DSEC,D,DA,DIC,DIK,DIFRD,DIFRDATA,DIFRFLD,DIFRDIC,DIFRGL,DIFRX,I,X,Y,Z
  1. S DSEC=$P(DIFR02,"^") ; **>> add file security if new file only <<**
  1. I 'DSEC,'$D(^DIC(DIFRFILE,0))#2 S DSEC=1 ; Check to see if the file was Deleted during Pre-Install
  1. ;delete DD wp text for file, field and x-ref description and field tech description
  1. ;also delete "NM" nodes when installing full DD at specified level
  1. ;
  1. ;^XTMP("XPDI",4861,"^DD",21489,21489,0)="FIELD^^1^2"
  1. ;^XTMP("XPDI",4861,"^DD",21489,21489,0,"IX","B",21489,.01)=""
  1. ;^XTMP("XPDI",4861,"^DD",21489,21489,0,"NM","MSC ORDERS HL7")=""
  1. ;^XTMP("XPDI",4861,"^DD",21489,21489,.01,0)="NAME^RF^^0;1^K:$L(X)>30
  1. ; parital DDs
  1. I 'DIFRFDD D
  1. .K @DIFRSA@("DIFRNI",DIFRFILE)
  1. .N DIFRD
  1. .S DIFRD=DIFRFILE
  1. .; loop thru sub DDs
  1. .F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. ..Q:$$UP(DIFRSA,DIFRFILE,DIFRD) ;check parent, quit if everything is OK
  1. ..S @DIFRSA@("DIFRNI",DIFRFILE,DIFRD)="" ;there is a problem, this node is process in tag DIKZ
  1. ..N DIFRNGF,DIFRNGFD
  1. ..S DIFRNGF=+$G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1))
  1. ..S DIFRNGFD=.01 F S DIFRNGFD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)) Q:DIFRNGFD="" Q:+$P($G(^(DIFRNGFD,0)),U,2)=DIFRD
  1. ..I DIFRNGFD'="" K @DIFRSA@("^DD",DIFRFILE,DIFRNGF,DIFRNGFD)
  1. ..Q
  1. .Q
  1. K:DIFRFDD ^DIC(DIFRFILE,"%D")
  1. S DIFRD=0
  1. F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. .I '$D(@DIFRFIA@(DIFRFILE,DIFRD)) S @DIFRFIA@(DIFRFILE,DIFRD)=0 ;MAKE SURE WE WILL CROSS-REFERENCE THIS DD
  1. .;S ^DD(DIFRD,0)="FIELD^NL^" ;p14 this was masking the problem of a partial multiple where the .01 field is missing
  1. .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
  1. .K:$D(@DIFRSA@("^DD",DIFRFILE,DIFRD,0,"NM"))\10 ^DD(DIFRD,0,"NM")
  1. .S DIFRFLD=0
  1. .F S DIFRFLD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD)) Q:DIFRFLD'>0 D
  1. ..K ^DD(DIFRD,DIFRFLD,21),^(23)
  1. ..S DIFRX=0
  1. ..F S DIFRX=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD,DIFRFLD,1,DIFRX)) Q:DIFRX'>0 D ;check cross ref.
  1. ...K ^DD(DIFRD,DIFRFLD,1,DIFRX,"%D") ;kill Description
  1. ...S Z=0 F S Z=$O(^DD(DIFRD,DIFRFLD,1,DIFRX,Z)) Q:'Z I Z'=1,Z'=2 K ^(Z) ;p21 kill spill over cross ref. code
  1. FULL I DIFRFDD F DIFRX="^DIC","^DD" D ;FULL DEFINITION
  1. .N X
  1. .I DIFRX="^DIC",$G(^DIC(DIFRFILE,0))]"" S X=$P(^(0),"^",3,9) ;REMEMBER NODES 3 &4 (LAST^COUNT)
  1. .D K12:DIFRX="^DD" M @DIFRX=@DIFRSA@(DIFRX,DIFRFILE) D UPDATED^DICATTA(DIFRFILE,-1) ;MOVE IN A WHOLE DD OR DIC NODE
  1. .I DIFRX="^DIC",$G(X)]"" S $P(^DIC(DIFRFILE,0),"^",3,9)=X
  1. .I DSEC,$D(@DIFRSA@("SEC",DIFRX,DIFRFILE)) M @DIFRX=@DIFRSA@("SEC",DIFRX,DIFRFILE)
  1. .Q
  1. PARTIAL I 'DIFRFDD D ;PARTIAL DEFINITION
  1. .N DIFRD
  1. .S DIFRD=0
  1. .F S DIFRD=$O(@DIFRSA@("^DD",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. ..I $D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q ;ABORT
  1. ..D K12(DIFRD) M ^DD(DIFRD)=@DIFRSA@("^DD",DIFRFILE,DIFRD) ;HERE IS WHERE A WHOLE DD COMES OVER!
  1. ..D UPDATED^DICATTA(DIFRD,-1) ;SET THE %MSC NODE
  1. SETUP ..I $G(@DIFRSA@("UP",DIFRFILE,DIFRD,-1)) S ^DD(DIFRD,0,"UP")=+^(-1) ;SET THE "UP" NODE, SINCE IT SEEMS NOT TO BE SENT WITH THE REST OF THE ^DD
  1. ..I DSEC,$D(@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)) M ^DD(DIFRD)=@DIFRSA@("SEC","^DD",DIFRFILE,DIFRD)
  1. ..Q
  1. .Q
  1. S DIFRD=0 F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. .I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q
  1. .S D=DIFRD,DIK="A" F S DIK=$O(^DD(D,DIK)) Q:DIK="" K ^(DIK)
  1. .S DA(1)=D,DIK="^DD("_D_"," D D IXALL^DIK L -^DD(0) ;CROSS-REFERENCE THE ^DD THAT WE HAVE BUILT
  1. ..N Z ;retry lock until success or 5 min. p19
  1. ..F Z=1:1:150 L +^DD(0):2 Q:$T
  1. ..E S DIFRMSGR="Can't Lock ^DD(0), file #"_DIFRFILE_" not installed!",Z=1/0 ;throw <DIVIDE> error to stop install
  1. ..Q
  1. .I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," D IXALL^DIK
  1. .Q
  1. I 'DIFRFDD D G IXKEY
  1. .Q:'$D(@DIFRSA@("^DD",DIFRFILE,DIFRFILE,.01))
  1. .S $P(@(^DIC(DIFRFILE,0,"GL")_"0)"),"^",2)=$$HDR2P^DIFROMSS(DIFRFILE)
  1. .Q
  1. S DIFRGL=^DIC(DIFRFILE,0,"GL"),DIFRDIC=$P(^DIC(DIFRFILE,0),U,1,2)
  1. S $P(DIFRDIC,"^",2)=@DIFRFIA@(DIFRFILE,0,0)
  1. I DIFRFDD,+$G(@DIFRFIA@(DIFRFILE,0,"VR")) S DIFRVR=^("VR") D
  1. .S ^DD(DIFRFILE,0,"VR")=$P(DIFRVR,"^")
  1. .S ^DD(DIFRFILE,0,"VRPK")=$P(DIFRVR,"^",2)
  1. .Q
  1. S DIFRDATA=$D(@(DIFRGL_"0)")),^(0)=DIFRDIC_"^"_$S(DIFRDATA#2:$P(^(0),"^",3,9),1:"^")
  1. ;
  1. IXKEY ; Bring INDEX and KEY entries
  1. K ^TMP("DIFROMS2",$J,"TRIG")
  1. S DIFRD=0
  1. F S DIFRD=$O(@DIFRSA@("IX",DIFRFILE,DIFRD)) Q:'DIFRD D DDIXIN^DIFROMSX(DIFRFILE,DIFRD,DIFRSA)
  1. K ^TMP("DIFROMS2",$J,"TRIG")
  1. S DIFRD=0
  1. F S DIFRD=$O(@DIFRSA@("KEY",DIFRFILE,DIFRD)) Q:'DIFRD D DDKEYIN^DIFROMSY(DIFRFILE,DIFRD,DIFRSA)
  1. ;
  1. DIKZ I $D(^DD(DIFRFILE,0,"DIK")) D
  1. .N %X,DIKJ,DIR,DMAX,X,Y,DIFRDIKA
  1. .D EN2^DIKZ(DIFRFILE,"",^DD(DIFRFILE,0,"DIK"),^DD("ROU"),"DIFRDIKA")
  1. .I $D(DIFRDIKA) M @DIFRSA@("DIKZ",DIFRFILE)=DIFRDIKA
  1. .S @DIFRSA@("DIKZ",DIFRFILE)=^DD(DIFRFILE,0,"DIK")
  1. .Q
  1. ;process errors
  1. I 'DIFRFDD,$D(@DIFRSA@("DIFRNI",DIFRFILE)) D
  1. .N DIFRD
  1. .S DIFRD=0
  1. .F S DIFRD=$O(@DIFRSA@("DIFRNI",DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. ..N DIFRERR S DIFRERR(1)=DIFRD
  1. ..D BLD^DIALOG(9512,.DIFRERR) ;"parent DD(s) missing"
  1. Q
  1. ;
  1. K12(DIFRD) N DD,D S DIFRD=+$G(DIFRD) ;DIFRD WILL BE THERE FOR A PARTIAL UPDATE
  1. F DD=0:0 S DD=$O(@DIFRSA@("^DD",DIFRFILE,DD)) Q:'DD I DIFRD=DD!'DIFRD D
  1. .F D=0:0 S D=$O(@DIFRSA@("^DD",DIFRFILE,DD,D)) Q:'D K ^DD(DD,D,12),^(12.1),^("V") ;p23 Kill 'SCREEN' and Variable pointer nodes, because they may not be coming in
  1. Q
  1. ;
  1. UP(ROOT,FILE,DDN) ;Return 1 if OK, or 0 for error p14
  1. Q:FILE=DDN 1 ;top level file
  1. Q:$D(^DD(DDN)) 1 ;subDD already exists
  1. Q:'$D(@ROOT@("UP",FILE,DDN)) 1 ;no parent in transport
  1. N T S T=0
  1. D UP1
  1. I $G(@ROOT@("FIA",FILE,DDN))=0 Q T ;full subDD
  1. I T,'$D(@ROOT@("FIA",FILE,DDN,.01)) S T=0 ;partial subDD, no subDD at site, no .01 field sent = error
  1. Q T
  1. ;
  1. UP1 N MP,PARENT,X ;p14
  1. S MP=0,X=""
  1. ;checks if parent exists or is in transport
  1. F S X=$O(@ROOT@("UP",FILE,DDN,X)) Q:X="" S PARENT=+^(X) D Q:T!(MP)
  1. .I $D(^DD(PARENT))!$D(@ROOT@("FIA",FILE,PARENT)) S:X>-2 T=1 Q ;***GFT
  1. .S MP=1
  1. .Q
  1. Q
  1. ;
  1. ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
  1. ;;FIA Node Is Set To "No DD Update";1;9503
  1. ;;Already Exist On Target System (INSTALL ONLY IF NEW);2;9504
  1. ;;Did Not Pass DD Screen;3;9505
  1. ;;FIA Array Does Not Exist;4;9511
  1. ;;Distribution Array Does Not Exist;5;9506
  1. ;;FIA File Number Invalid;6;9507
  1. ;;Partial DD/File Does Not Already Exist On Target System;7;9508