- DIFROMSI ;SCISC/DCL-EDE IN ;3:19 PM 16 Nov 2001 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**94**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
- DIFROMSI ;SCISC/DCL-EDE IN ;3:19 PM 16 Nov 2001 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**94**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 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
