- DIFGA ;SFISC/XAK-FILEGRAM TEMPLATES ;3/5/93 1:22 PM
- ;;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.
- ;
- S DIC=DI,(DIPT,DC(0))=DA,DC(1)=0 D INIT^DIFGA1,GET^DIFGB,L S L=1,DE="",DJ=0
- K DNP Q
- ;
- EN D INIT^DIFGA1 I $D(DIAX) G Q:Y'>0
- L D RD I X=U!$D(DTOUT) G Q
- I X="",DL=1 D:DJ ^DIFGB D:$D(DIAXE01)&'(U[X) F1^DIAXMS G:(+$G(DIERR)&'(U[X)) ERR G Q
- I 'DJ,$E(X)="[" D TEM^DIFGB G Q:X=U
- D PR
- I $D(Y(0)),+$P(Y(0),U,2),$P(^DD(+$P(Y(0),U,2),.01,0),U,2)["W" S Y(0)=$P(Y,U,2) I $D(DIAX) S $P(Y(0),U,2)=$P(^(0),U,2)
- D:$D(Y) ST G Q:$D(DIRUT)
- I DINS,DINS<DL S DINS(DINS)=DC,DC=0,DINS=""
- G L
- ERR W !!,$C(7),"THE DESTINATION FILE DATA DICTIONARY SHOULD BE MODIFIED PRIOR TO ANY MOVEMENT",!,"OF EXTRACT DATA!"
- Q G Q^DIFGA1
- ;
- RD ;
- S DU=$P(^DD(DK,0),U) S:DU="FIELD" DU=$O(^(0,"NM",0))_" "_DU
- W !?DL+DL-2 W $S(DJ:" THEN",1:"FIRST")_$S($D(DIAX):" EXTRACT ",1:" SEND ")_DU_": "
- G 1:'DC
- D:'$D(DC(DC)) GET^DIFGB G 1:'DC W $P(DC(DC),U)
- I $L($P(DC(DC),U))>19 S Y=$P(DC(DC),U) D RW^DIR2 G 2
- I DC(DC)]"" W "// "
- 1 R X:DTIME I '$T S DTOUT=1 Q
- 2 Q:'DC S DINS=X?1"^"1.E,X=$S(DINS:$E(X,2,999),X="":$P(DC(DC),U),1:X) S:DC(DC)=""&$L(X) DINS=1 S:DINS DINS=DL
- Q
- PR ;
- S (S,DM,DIFG,DIFGLINK)="" K DIC,Y
- I X="" D UP Q
- I X?1"""".E1"""".E G QQ
- I X="ALL",'DJ W " Do you mean ALL the fields in the file" S %=2 D YN^DICN S Y=$S(%<0:"",%=1:"ALL",1:%) Q:X[Y W !?10,X
- S DIC="^DD(DK,",DIC(0)="ZE"_$E("O",DC>0),DIC("W")="W:$P(^(0),U,2) "" (multiple)"""
- S DIC("S")=$S('$D(DIAX):"I $P(^(0),U,2)'[""C""",1:"") S:$D(DICS) DIC("S")=DIC("S")_" X DICS"
- D ^DIC Q:Y>0 I X?1"?".E K Y Q
- I DC,X="@" D DC K Y Q
- S DIC(0)="EYZ",D="GR" I $D(^DD(DK,D)),'$D(DIAX) D IX^DIC Q:$D(Y)=11
- G:X'?.E1":" QQ
- I $L(X,":")>2 S %=$O(^DD(DK,"B",$P(X,":"),0)) G:'% QQ G:$P(^DD(DK,%,0),U,2)'["C" QQ
- S DM=X,DQI="DIP(",DA="",DICOMP=DIL_$E("?",''L)_"T"
- S (DICOMPX,DICMX)="",DIFG=$S($L(X,":")>2:5,1:1) D ^DICOMPW G:'$D(X) QQ
- S:+DIFG("DICOMP")=DK DM=$P(^DD(DK,+$P(DIFG("DICOMP"),U,2),0),U,1)_":" S:DIFG?1A.E DIFGLINK=DIFG,DIFG=4 Q
- ST ;
- I $D(DIAX),Y="ALL" W !,$C(7),"SORRY, THIS FUNCTIONALITY IS NOT SUPPORTED AT THIS TIME." Q
- I Y="ALL" D N S DJ=DJ+1 K DIFGALL Q
- I 'Y,$D(Y)=11 F Y=0:0 S Y=$O(Y(Y)) Q:Y'>0 S X=^DD(DK,Y,0) D Y
- Q:Y'>0
- I $D(DIAX),$D(Y)=11,$P(Y(0),U,2)["m" W !,$C(7),"SORRY, CANNOT EXTRACT THIS TYPE OF COMPUTED FIELD AT THIS TIME." Q
- I DIFG]"" S %=Y,S=U_$P(DP,U,2)_U_S,X=1 D D1 S DK=+DP,Y=0,DIL=+% D Y Q
- I $P(Y(0),U,2) S DM=$P(Y(0),U) D D,Y S X=$P($P(Y(0),U,4),";"),I(DIL)=$S(+X=X:X,1:$C(34)_X_$C(34)),J(DIL)=DK Q
- S Y=+Y D Y
- Q
- ;
- D D D1 S DK=+$P(^DD(DK,+Y,0),U,2),DIL=DIL+1,Y=0,DIFG=3 Q
- D1 S DJ1(DL)=DJ,DIL(DL)=DIL,DJ=0,C(DL)=C,DL(DL)=DK,DL=DL+1,(C,C(0))=C(0)+1
- Q
- ;
- U S DL=DL-1,C=C(DL),DK=DL(DL),DIL=DIL(DL) S:$D(DIAX) (DIAXF,DIAXFILE)=DIAXDL(DL) S DJ=$S(DJ&'DJ1(DL):1,1:DJ1(DL)) K:DL=1 DIAXSB
- I $D(DINS(DL)) S DC=DINS(DL)-1 K DINS(DL)
- F %=DIL:0 S %=$O(I(%)) Q:%'>0 K I(%),J(%),DJ1(%)
- Q
- ;
- DC I 'DINS K:DC>1 DC(DC) D DC1 S DC=DC+1
- Q
- DC1 Q:(X'="@"!(DC'=2)) S DC=DC+1
- F Q:'$D(DC(DC)) K DC(DC) S DC=DC+1
- S DC=DC-2 Q
- ;
- Y S S=Y_S
- DJ I $D(DIAX) D DIAX Q
- I C,'DJ1(DL-1) S:'$D(^UTILITY("DIFG",$J,C-1)) ^(C-1)=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U
- I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK
- S:$D(DIFGALL) $P(^UTILITY("DIFG",$J,C),U,8)=1
- S:S DJ=DJ+1,^(C,DJ)=S S S="" D DC:DC Q
- ;
- N S I=DL,DM="ALL",DIFGALL=1 D Y S DM=""
- NN S Y=.001 ;I $D(^DD(DK,Y)) D Y
- A S Y=$O(^DD(DK,Y)) I $D(^(Y,8)),$D(DICS) X DICS E G A
- I Y'>0 G UP:I'<DL D U S Y=Y(DL) G A
- I $P(^(0),U,2) G A:$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W" S Y(DL)=Y D D,Y G NN
- G A ;D Y G A
- ;
- UP K DIC I DL>1 D U,DC:DC
- Q
- ;
- QQ W $C(7)," ??" K Y Q
- ;
- DIAX I 'S,$G(DIFG)>2 S DIAXDICA=$S(DIFG=3:Y(0,0),1:DM) D ^DIAXMS I $D(DIAXUP) D UP K DIAXUP,DIAXSB Q
- S DIAXDK(DK)=DIAXF,DIAXDL(DL)=DIAXF
- I C,'$D(^UTILITY("DIFG",$J,C(DL-1))) S ^(C(DL-1))=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U_U_U_DIAXDL(DL-1)_U_DIAXDK(DL(DL-1)),DIAXE01(DIAXDL(DL-1))=(DL-1)_U_$G(DIAXSB)
- I '$D(^UTILITY("DIFG",$J,C))#2 S ^(C)=DK_U_DL_U_$S(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK_U_U_DIAXF_U_$S(DL>1:DIAXDK(DL(DL-1)),1:DIAXF)_U_$G(DIAXNP(DL-1)),DIAXE01(DIAXF)=DK_U_$G(DIAXSB)
- I S D EN2^DIAXM Q:$D(DIRUT)
- S S="" D DC:DC W ! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGA 4516 printed Feb 19, 2025@00:13:59 Page 2
- DIFGA ;SFISC/XAK-FILEGRAM TEMPLATES ;3/5/93 1:22 PM
- +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 ;
- +7 SET DIC=DI
- SET (DIPT,DC(0))=DA
- SET DC(1)=0
- DO INIT^DIFGA1
- DO GET^DIFGB
- DO L
- SET L=1
- SET DE=""
- SET DJ=0
- +8 KILL DNP
- QUIT
- +9 ;
- EN DO INIT^DIFGA1
- IF $DATA(DIAX)
- if Y'>0
- GOTO Q
- L DO RD
- IF X=U!$DATA(DTOUT)
- GOTO Q
- +1 IF X=""
- IF DL=1
- if DJ
- DO ^DIFGB
- if $DATA(DIAXE01)&'(U[X)
- DO F1^DIAXMS
- if (+$GET(DIERR)&'(U[X))
- GOTO ERR
- GOTO Q
- +2 IF 'DJ
- IF $EXTRACT(X)="["
- DO TEM^DIFGB
- if X=U
- GOTO Q
- +3 DO PR
- +4 IF $DATA(Y(0))
- IF +$PIECE(Y(0),U,2)
- IF $PIECE(^DD(+$PIECE(Y(0),U,2),.01,0),U,2)["W"
- SET Y(0)=$PIECE(Y,U,2)
- IF $DATA(DIAX)
- SET $PIECE(Y(0),U,2)=$PIECE(^(0),U,2)
- +5 if $DATA(Y)
- DO ST
- if $DATA(DIRUT)
- GOTO Q
- +6 IF DINS
- IF DINS<DL
- SET DINS(DINS)=DC
- SET DC=0
- SET DINS=""
- +7 GOTO L
- ERR WRITE !!,$CHAR(7),"THE DESTINATION FILE DATA DICTIONARY SHOULD BE MODIFIED PRIOR TO ANY MOVEMENT",!,"OF EXTRACT DATA!"
- Q GOTO Q^DIFGA1
- +1 ;
- RD ;
- +1 SET DU=$PIECE(^DD(DK,0),U)
- if DU="FIELD"
- SET DU=$ORDER(^(0,"NM",0))_" "_DU
- +2 WRITE !?DL+DL-2
- WRITE $SELECT(DJ:" THEN",1:"FIRST")_$SELECT($DATA(DIAX):" EXTRACT ",1:" SEND ")_DU_": "
- +3 if 'DC
- GOTO 1
- +4 if '$DATA(DC(DC))
- DO GET^DIFGB
- if 'DC
- GOTO 1
- WRITE $PIECE(DC(DC),U)
- +5 IF $LENGTH($PIECE(DC(DC),U))>19
- SET Y=$PIECE(DC(DC),U)
- DO RW^DIR2
- GOTO 2
- +6 IF DC(DC)]""
- WRITE "// "
- 1 READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- QUIT
- 2 if 'DC
- QUIT
- SET DINS=X?1"^"1.E
- SET X=$SELECT(DINS:$EXTRACT(X,2,999),X="":$PIECE(DC(DC),U),1:X)
- if DC(DC)=""&$LENGTH(X)
- SET DINS=1
- if DINS
- SET DINS=DL
- +1 QUIT
- PR ;
- +1 SET (S,DM,DIFG,DIFGLINK)=""
- KILL DIC,Y
- +2 IF X=""
- DO UP
- QUIT
- +3 IF X?1"""".E1"""".E
- GOTO QQ
- +4 IF X="ALL"
- IF 'DJ
- WRITE " Do you mean ALL the fields in the file"
- SET %=2
- DO YN^DICN
- SET Y=$SELECT(%<0:"",%=1:"ALL",1:%)
- if X[Y
- QUIT
- WRITE !?10,X
- +5 SET DIC="^DD(DK,"
- SET DIC(0)="ZE"_$EXTRACT("O",DC>0)
- SET DIC("W")="W:$P(^(0),U,2) "" (multiple)"""
- +6 SET DIC("S")=$SELECT('$DATA(DIAX):"I $P(^(0),U,2)'[""C""",1:"")
- if $DATA(DICS)
- SET DIC("S")=DIC("S")_" X DICS"
- +7 DO ^DIC
- if Y>0
- QUIT
- IF X?1"?".E
- KILL Y
- QUIT
- +8 IF DC
- IF X="@"
- DO DC
- KILL Y
- QUIT
- +9 SET DIC(0)="EYZ"
- SET D="GR"
- IF $DATA(^DD(DK,D))
- IF '$DATA(DIAX)
- DO IX^DIC
- if $DATA(Y)=11
- QUIT
- +10 if X'?.E1"
- GOTO QQ
- +11 IF $LENGTH(X,":")>2
- SET %=$ORDER(^DD(DK,"B",$PIECE(X,":"),0))
- if '%
- GOTO QQ
- if $PIECE(^DD(DK,%,0),U,2)'["C"
- GOTO QQ
- +12 SET DM=X
- SET DQI="DIP("
- SET DA=""
- SET DICOMP=DIL_$EXTRACT("?",''L)_"T"
- +13 SET (DICOMPX,DICMX)=""
- SET DIFG=$SELECT($LENGTH(X,":")>2:5,1:1)
- DO ^DICOMPW
- if '$DATA(X)
- GOTO QQ
- +14 if +DIFG("DICOMP")=DK
- SET DM=$PIECE(^DD(DK,+$PIECE(DIFG("DICOMP"),U,2),0),U,1)_":"
- if DIFG?1A.E
- SET DIFGLINK=DIFG
- SET DIFG=4
- QUIT
- ST ;
- +1 IF $DATA(DIAX)
- IF Y="ALL"
- WRITE !,$CHAR(7),"SORRY, THIS FUNCTIONALITY IS NOT SUPPORTED AT THIS TIME."
- QUIT
- +2 IF Y="ALL"
- DO N
- SET DJ=DJ+1
- KILL DIFGALL
- QUIT
- +3 IF 'Y
- IF $DATA(Y)=11
- FOR Y=0:0
- SET Y=$ORDER(Y(Y))
- if Y'>0
- QUIT
- SET X=^DD(DK,Y,0)
- DO Y
- +4 if Y'>0
- QUIT
- +5 IF $DATA(DIAX)
- IF $DATA(Y)=11
- IF $PIECE(Y(0),U,2)["m"
- WRITE !,$CHAR(7),"SORRY, CANNOT EXTRACT THIS TYPE OF COMPUTED FIELD AT THIS TIME."
- QUIT
- +6 IF DIFG]""
- SET %=Y
- SET S=U_$PIECE(DP,U,2)_U_S
- SET X=1
- DO D1
- SET DK=+DP
- SET Y=0
- SET DIL=+%
- DO Y
- QUIT
- +7 IF $PIECE(Y(0),U,2)
- SET DM=$PIECE(Y(0),U)
- DO D
- DO Y
- SET X=$PIECE($PIECE(Y(0),U,4),";")
- SET I(DIL)=$SELECT(+X=X:X,1:$CHAR(34)_X_$CHAR(34))
- SET J(DIL)=DK
- QUIT
- +8 SET Y=+Y
- DO Y
- +9 QUIT
- +10 ;
- D DO D1
- SET DK=+$PIECE(^DD(DK,+Y,0),U,2)
- SET DIL=DIL+1
- SET Y=0
- SET DIFG=3
- QUIT
- D1 SET DJ1(DL)=DJ
- SET DIL(DL)=DIL
- SET DJ=0
- SET C(DL)=C
- SET DL(DL)=DK
- SET DL=DL+1
- SET (C,C(0))=C(0)+1
- +1 QUIT
- +2 ;
- U SET DL=DL-1
- SET C=C(DL)
- SET DK=DL(DL)
- SET DIL=DIL(DL)
- if $DATA(DIAX)
- SET (DIAXF,DIAXFILE)=DIAXDL(DL)
- SET DJ=$SELECT(DJ&'DJ1(DL):1,1:DJ1(DL))
- if DL=1
- KILL DIAXSB
- +1 IF $DATA(DINS(DL))
- SET DC=DINS(DL)-1
- KILL DINS(DL)
- +2 FOR %=DIL:0
- SET %=$ORDER(I(%))
- if %'>0
- QUIT
- KILL I(%),J(%),DJ1(%)
- +3 QUIT
- +4 ;
- DC IF 'DINS
- if DC>1
- KILL DC(DC)
- DO DC1
- SET DC=DC+1
- +1 QUIT
- DC1 if (X'="@"!(DC'=2))
- QUIT
- SET DC=DC+1
- +1 FOR
- if '$DATA(DC(DC))
- QUIT
- KILL DC(DC)
- SET DC=DC+1
- +2 SET DC=DC-2
- QUIT
- +3 ;
- Y SET S=Y_S
- DJ IF $DATA(DIAX)
- DO DIAX
- QUIT
- +1 IF C
- IF 'DJ1(DL-1)
- if '$DATA(^UTILITY("DIFG",$JOB,C-1))
- SET ^(C-1)=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U
- +2 IF '$DATA(^UTILITY("DIFG",$JOB,C))#2
- SET ^(C)=DK_U_DL_U_$SELECT(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK
- +3 if $DATA(DIFGALL)
- SET $PIECE(^UTILITY("DIFG",$JOB,C),U,8)=1
- +4 if S
- SET DJ=DJ+1
- SET ^(C,DJ)=S
- SET S=""
- if DC
- DO DC
- QUIT
- +5 ;
- N SET I=DL
- SET DM="ALL"
- SET DIFGALL=1
- DO Y
- SET DM=""
- NN ;I $D(^DD(DK,Y)) D Y
- SET Y=.001
- A SET Y=$ORDER(^DD(DK,Y))
- IF $DATA(^(Y,8))
- IF $DATA(DICS)
- XECUTE DICS
- IF '$TEST
- GOTO A
- +1 IF Y'>0
- if I'<DL
- GOTO UP
- DO U
- SET Y=Y(DL)
- GOTO A
- +2 IF $PIECE(^(0),U,2)
- if $PIECE(^DD(+$PIECE(^(0),U,2),.01,0),U,2)["W"
- GOTO A
- SET Y(DL)=Y
- DO D
- DO Y
- GOTO NN
- +3 ;D Y G A
- GOTO A
- +4 ;
- UP KILL DIC
- IF DL>1
- DO U
- if DC
- DO DC
- +1 QUIT
- +2 ;
- QQ WRITE $CHAR(7)," ??"
- KILL Y
- QUIT
- +1 ;
- DIAX IF 'S
- IF $GET(DIFG)>2
- SET DIAXDICA=$SELECT(DIFG=3:Y(0,0),1:DM)
- DO ^DIAXMS
- IF $DATA(DIAXUP)
- DO UP
- KILL DIAXUP,DIAXSB
- QUIT
- +1 SET DIAXDK(DK)=DIAXF
- SET DIAXDL(DL)=DIAXF
- +2 IF C
- IF '$DATA(^UTILITY("DIFG",$JOB,C(DL-1)))
- SET ^(C(DL-1))=DL(DL-1)_U_(DL-1)_U_U_U_U_DT_U_U_U_DIAXDL(DL-1)_U_DIAXDK(DL(DL-1))
- SET DIAXE01(DIAXDL(DL-1))=(DL-1)_U_$GET(DIAXSB)
- +3 IF '$DATA(^UTILITY("DIFG",$JOB,C))#2
- SET ^(C)=DK_U_DL_U_$SELECT(DL>1:DL(DL-1),1:"")_U_DIFG_U_DM_U_DT_U_DIFGLINK_U_U_DIAXF_U_$SELECT(DL>1:DIAXDK(DL(DL-1)),1:DIAXF)_U_$GET(DIAXNP(DL-1))
- SET DIAXE01(DIAXF)=DK_U_$GET(DIAXSB)
- +4 IF S
- DO EN2^DIAXM
- if $DATA(DIRUT)
- QUIT
- +5 SET S=""
- if DC
- DO DC
- WRITE !
- QUIT
