DIFROMSI ;SCISC/DCL-EDE IN ;3:19 PM 16 Nov 2001
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
FPRE(DIFRFILE,DIFRFLG,DIFRNAME,DIFRSA) ;
G FPRE^DIFROMSC
EPRE(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA,DIFROIEN) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1
I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
N DIOVRD S DIOVRD=1
N DIFRRDA,DIFRX
S DIFRFILE=$G(DIFRFILE) S:DIFRFILE'>0 DIFRFILE=$G(XPDFIL)
I DIFRFILE'>0 D BLD^DIALOG(9521) Q
S DIFRIEN=$G(DIFRIEN) S:DIFRIEN'>0 DIFRIEN=$G(DA)
I DIFRIEN'>0 D BLD^DIALOG(9522) Q
S DIFROIEN=$G(DIFROIEN) S:DIFROIEN'>0 DIFROIEN=$G(OLDA)
I DIFROIEN'>0 D BLD^DIALOG(9523) Q
I $G(DIFRNAME)="" D BLD^DIALOG(9524) Q
I $G(DIFRSA)="" S DIFRSA=$NA(^XTMP("XPDI",DIFRNAME,"KRN"))
S DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
S DIFRX=$P(@DIFRRDA@(0),"^")
G:DIFRFILE=.84 DIALOG
;
; preserve security codes if template/form is not new
I $G(DIFRFLG)'["N",DIFRFILE'=.5 D
.N X,Y
.S Y=@DIFRRDA@(0)
.S X=@DIFRSA@(DIFRFILE,DIFROIEN,0),$P(X,U,3)=$P(Y,U,3),$P(X,U,6)=$P(Y,U,6),^(0)=X
.Q
;
I DIFRFILE'=.403 K @DIFRRDA
E D
.Q:$G(DIFRFLG)["N"
.N DA,DIC,DIK,DINUM,X,Y,DO
.S DIK="^DIST(.403,",DA=DIFRIEN
.D ^DIK
.S DIC="^DIST(.403,",DIC(0)="LX",X=DIFRX,DINUM=DIFRIEN
.D FILE^DICN
.Q
I DIFRFILE=.403 D
.N DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
.S DIFRJ=0
.F S DIFRJ=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ)) Q:'DIFRJ I $D(^(DIFRJ,0)) S DIFRP=$P(^(0),"^",2) D
..S:DIFRP]"" DIFRP=$O(^DIST(.404,"B",DIFRP,0))
..S:DIFRP $P(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
..S DIFRL=0
..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL)) Q:'DIFRL S DIFRA0=$G(^(DIFRL,0)),DIFRP=$P(DIFRA0,"^") I DIFRP]"" D
...S DIFRP=$O(^DIST(.404,"B",DIFRP,0)) I DIFRP D
....S $P(DIFRA0,"^")=DIFRP,@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
....N DIFRX
....S DIFRX=0
....F S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)) Q:DIFRX="" S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,DIFRX)=^(DIFRX)
....Q
...Q
..S DIFRA0=$G(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
..Q:DIFRA0=""
..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
..S (DIFRA1,DIFRA2)=0
..S DIFRL=0
..F S DIFRL=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL)) Q:'DIFRL S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0),DIFRA1=DIFRL,DIFRA2=DIFRA2+1 D
...N DIFRX
...S DIFRX=0
...F S DIFRX=$O(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL,DIFRX)) Q:DIFRX="" S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)=^(DIFRX)
...Q
..S $P(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
..S @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
..K @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
..Q
.Q
Q
DIALOG N DIFRF,DIFRX
S DIFRF=$P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)
I DIFRF]"" D
.S DIFRF=$O(^DIC(9.4,"B",DIFRF,0)) I DIFRF,$O(^(DIFRF)) D S DIFRF=""
..N DIFRERR S DIFRERR(1)=DIFRF,DIFRERR(2)=DIFRIEN
..D BLD^DIALOG(9525,.DIFRERR)
..Q
.S $P(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)=DIFRF
F DIFRX=1,2,3,5,6 K @DIFRRDA@(DIFRX)
Q
EPOST(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA) ;
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1
I $G(U)'="^"!($G(DT)'>0)!($G(DTIME)'>0)!('$D(DUZ)) D DT^DICRW
N DIOVRD S DIOVRD=1
I '$G(DIFRFILE)!('$G(DIFRIEN)) Q
I $G(DIFRNAME)="" Q
S:$G(DIFRSA)']"" DIFRSA=$NA(^XTMP("XPDI",DIFRNAME))
N DA,DIFR,DIFR3,DIFROU,DIK,DMAX,DNM,X,Y,Z,DIFRTN
S DIK=$$ROOT^DILFD(DIFRFILE),DA=DIFRIEN
D IX1^DIK
I DIFRFILE=.403,DIFRIEN D ENGRP^DDSZ(DIFRIEN) Q
S DIFR=$S(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",1:"")
Q:DIFR=""
I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
E S DISYS=^DD("OS")
I '$D(^DD("OS",DISYS,"ZS")) D BLD^DIALOG(9526) Q
S Y=DIFRIEN
I $D(@("^"_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S (DIFROU,X)=^("ROUOLD"),DIFRTN=$P(^(0),"^") D:X]""
.N %X,DIR,DMAX,X,Y,DIFRZTA
.S DIFR3="DI"_$E(DIFR,3)_"Z"
.I $$VAL^DIFROMSS(DIFRFILE,DIFRIEN) D Q
..D @("EN2^"_DIFR3_"(DIFRIEN,"""",DIFROU,"""",""DIFRZTA"")")
..I $D(DIFRZTA) M @DIFRSA@(DIFR3,DIFRIEN)=DIFRZTA
..S @DIFRSA@(DIFR3,DIFRIEN)=DIFROU
..Q
.N DIFRTT,DIFRERR S DIFRTT=$S(DIFRFILE=.4:"PRINT",1:"INPUT")
.S DIFRERR(1)=DIFRTT,DIFRERR(2)=DIFRTN
.D BLD^DIALOG(9528,.DIFRERR)
.Q
Q
FPOST ;
G FPOST^DIFROMSC
EXIT I $G(DIFRMSGR)]"" D CALLOUT^DIEFU(DIFRMSGR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSI 4659 printed Sep 23, 2025@20:24:27 Page 2
DIFROMSI ;SCISC/DCL-EDE IN ;3:19 PM 16 Nov 2001
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
FPRE(DIFRFILE,DIFRFLG,DIFRNAME,DIFRSA) ;
+1 GOTO FPRE^DIFROMSC
EPRE(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA,DIFROIEN) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
+3 IF $GET(U)'="^"!($GET(DT)'>0)!($GET(DTIME)'>0)!('$DATA(DUZ))
DO DT^DICRW
+4 NEW DIOVRD
SET DIOVRD=1
+5 NEW DIFRRDA,DIFRX
+6 SET DIFRFILE=$GET(DIFRFILE)
if DIFRFILE'>0
SET DIFRFILE=$GET(XPDFIL)
+7 IF DIFRFILE'>0
DO BLD^DIALOG(9521)
QUIT
+8 SET DIFRIEN=$GET(DIFRIEN)
if DIFRIEN'>0
SET DIFRIEN=$GET(DA)
+9 IF DIFRIEN'>0
DO BLD^DIALOG(9522)
QUIT
+10 SET DIFROIEN=$GET(DIFROIEN)
if DIFROIEN'>0
SET DIFROIEN=$GET(OLDA)
+11 IF DIFROIEN'>0
DO BLD^DIALOG(9523)
QUIT
+12 IF $GET(DIFRNAME)=""
DO BLD^DIALOG(9524)
QUIT
+13 IF $GET(DIFRSA)=""
SET DIFRSA=$NAME(^XTMP("XPDI",DIFRNAME,"KRN"))
+14 SET DIFRRDA=$$CREF^DIQGU($$ROOT^DIQGU(DIFRFILE)_DIFRIEN)
+15 SET DIFRX=$PIECE(@DIFRRDA@(0),"^")
+16 if DIFRFILE=.84
GOTO DIALOG
+17 ;
+18 ; preserve security codes if template/form is not new
+19 IF $GET(DIFRFLG)'["N"
IF DIFRFILE'=.5
Begin DoDot:1
+20 NEW X,Y
+21 SET Y=@DIFRRDA@(0)
+22 SET X=@DIFRSA@(DIFRFILE,DIFROIEN,0)
SET $PIECE(X,U,3)=$PIECE(Y,U,3)
SET $PIECE(X,U,6)=$PIECE(Y,U,6)
SET ^(0)=X
+23 QUIT
End DoDot:1
+24 ;
+25 IF DIFRFILE'=.403
KILL @DIFRRDA
+26 IF '$TEST
Begin DoDot:1
+27 if $GET(DIFRFLG)["N"
QUIT
+28 NEW DA,DIC,DIK,DINUM,X,Y,DO
+29 SET DIK="^DIST(.403,"
SET DA=DIFRIEN
+30 DO ^DIK
+31 SET DIC="^DIST(.403,"
SET DIC(0)="LX"
SET X=DIFRX
SET DINUM=DIFRIEN
+32 DO FILE^DICN
+33 QUIT
End DoDot:1
+34 IF DIFRFILE=.403
Begin DoDot:1
+35 NEW DIFRA0,DIFRA1,DIFRA2,DIFRJ,DIFRL,DIFRP,DIFRX,DIFRY
+36 SET DIFRJ=0
+37 FOR
SET DIFRJ=$ORDER(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ))
if 'DIFRJ
QUIT
IF $DATA(^(DIFRJ,0))
SET DIFRP=$PIECE(^(0),"^",2)
Begin DoDot:2
+38 if DIFRP]""
SET DIFRP=$ORDER(^DIST(.404,"B",DIFRP,0))
+39 if DIFRP
SET $PIECE(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,0),"^",2)=DIFRP
+40 SET DIFRL=0
+41 FOR
SET DIFRL=$ORDER(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL))
if 'DIFRL
QUIT
SET DIFRA0=$GET(^(DIFRL,0))
SET DIFRP=$PIECE(DIFRA0,"^")
IF DIFRP]""
Begin DoDot:3
+42 SET DIFRP=$ORDER(^DIST(.404,"B",DIFRP,0))
IF DIFRP
Begin DoDot:4
+43 SET $PIECE(DIFRA0,"^")=DIFRP
SET @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,0)=DIFRA0
+44 NEW DIFRX
+45 SET DIFRX=0
+46 FOR
SET DIFRX=$ORDER(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX))
if DIFRX=""
QUIT
SET @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRP,DIFRX)=^(DIFRX)
+47 QUIT
End DoDot:4
+48 QUIT
End DoDot:3
+49 SET DIFRA0=$GET(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0))
+50 if DIFRA0=""
QUIT
+51 KILL @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40)
+52 SET (DIFRA1,DIFRA2)=0
+53 SET DIFRL=0
+54 FOR
SET DIFRL=$ORDER(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL))
if 'DIFRL
QUIT
SET @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,0)=^(DIFRL,0)
SET DIFRA1=DIFRL
SET DIFRA2=DIFRA2+1
Begin DoDot:3
+55 NEW DIFRX
+56 SET DIFRX=0
+57 FOR
SET DIFRX=$ORDER(@DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK",DIFRL,DIFRX))
if DIFRX=""
QUIT
SET @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,DIFRL,DIFRX)=^(DIFRX)
+58 QUIT
End DoDot:3
+59 SET $PIECE(DIFRA0,"^",3,4)=DIFRA1_"^"_DIFRA2
+60 SET @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,40,0)=DIFRA0
+61 KILL @DIFRSA@(DIFRFILE,DIFROIEN,40,DIFRJ,"BLK")
+62 QUIT
End DoDot:2
+63 QUIT
End DoDot:1
+64 QUIT
DIALOG NEW DIFRF,DIFRX
+1 SET DIFRF=$PIECE(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)
+2 IF DIFRF]""
Begin DoDot:1
+3 SET DIFRF=$ORDER(^DIC(9.4,"B",DIFRF,0))
IF DIFRF
IF $ORDER(^(DIFRF))
Begin DoDot:2
+4 NEW DIFRERR
SET DIFRERR(1)=DIFRF
SET DIFRERR(2)=DIFRIEN
+5 DO BLD^DIALOG(9525,.DIFRERR)
+6 QUIT
End DoDot:2
SET DIFRF=""
+7 SET $PIECE(@DIFRSA@(DIFRFILE,DIFROIEN,0),"^",4)=DIFRF
End DoDot:1
+8 FOR DIFRX=1,2,3,5,6
KILL @DIFRRDA@(DIFRX)
+9 QUIT
EPOST(DIFRFILE,DIFRIEN,DIFRFLG,DIFRNAME,DIFRSA) ;
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
+3 IF $GET(U)'="^"!($GET(DT)'>0)!($GET(DTIME)'>0)!('$DATA(DUZ))
DO DT^DICRW
+4 NEW DIOVRD
SET DIOVRD=1
+5 IF '$GET(DIFRFILE)!('$GET(DIFRIEN))
QUIT
+6 IF $GET(DIFRNAME)=""
QUIT
+7 if $GET(DIFRSA)']""
SET DIFRSA=$NAME(^XTMP("XPDI",DIFRNAME))
+8 NEW DA,DIFR,DIFR3,DIFROU,DIK,DMAX,DNM,X,Y,Z,DIFRTN
+9 SET DIK=$$ROOT^DILFD(DIFRFILE)
SET DA=DIFRIEN
+10 DO IX1^DIK
+11 IF DIFRFILE=.403
IF DIFRIEN
DO ENGRP^DDSZ(DIFRIEN)
QUIT
+12 SET DIFR=$SELECT(DIFRFILE=.4:"DIPT",DIFRFILE=.402:"DIE",1:"")
+13 if DIFR=""
QUIT
+14 IF ^DD("VERSION")>17.4
IF '$DATA(DISYS)
DO OS^DII
+15 IF '$TEST
SET DISYS=^DD("OS")
+16 IF '$DATA(^DD("OS",DISYS,"ZS"))
DO BLD^DIALOG(9526)
QUIT
+17 SET Y=DIFRIEN
+18 IF $DATA(@("^"_DIFR_"(Y,""ROU"")"))
KILL ^("ROU")
IF $DATA(^("ROUOLD"))
SET (DIFROU,X)=^("ROUOLD")
SET DIFRTN=$PIECE(^(0),"^")
if X]""
Begin DoDot:1
+19 NEW %X,DIR,DMAX,X,Y,DIFRZTA
+20 SET DIFR3="DI"_$EXTRACT(DIFR,3)_"Z"
+21 IF $$VAL^DIFROMSS(DIFRFILE,DIFRIEN)
Begin DoDot:2
+22 DO @("EN2^"_DIFR3_"(DIFRIEN,"""",DIFROU,"""",""DIFRZTA"")")
+23 IF $DATA(DIFRZTA)
MERGE @DIFRSA@(DIFR3,DIFRIEN)=DIFRZTA
+24 SET @DIFRSA@(DIFR3,DIFRIEN)=DIFROU
+25 QUIT
End DoDot:2
QUIT
+26 NEW DIFRTT,DIFRERR
SET DIFRTT=$SELECT(DIFRFILE=.4:"PRINT",1:"INPUT")
+27 SET DIFRERR(1)=DIFRTT
SET DIFRERR(2)=DIFRTN
+28 DO BLD^DIALOG(9528,.DIFRERR)
+29 QUIT
End DoDot:1
+30 QUIT
FPOST ;
+1 GOTO FPOST^DIFROMSC
EXIT IF $GET(DIFRMSGR)]""
DO CALLOUT^DIEFU(DIFRMSGR)
+1 QUIT
