- DIFG5 ;SFISC/DG(OHPRD)-MISC FUNCTIONS ;3/11/93 1:25 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.
- ;
- CHECKY ;CHECKS Y AFTER DIC CALL
- I Y>0,DIFGTYP="FILE"!(DIFGTYP="MV FIELD"),$P(DIFGMO(DIFGMULT),U)="L" S ^("MODE")="M"_"^"_$P(^UTILITY("DIFG",$J,DIFGINCR,DIFGDIC,"MODE"),U,2)
- I Y>0 G X1
- S DIFGCHEK=0 I DIFGTYP="MV FIELD"!(DIFGTYP="FILE") S DIFGCHEK=1
- I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP'="MV FIELD" S X=$S($D(DIFG("ACGRV")):X_"^N",1:X),DIFGSKIP(DIFGMULT)="" D ^DIFG4 G X1 ;Set X to X^N if internal pointer value was used in lookup, lets ^DIFG7 know if X internal value or not
- I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="L",DIFGTYP="MV FIELD" S DIFGSKIP(DIFGMULT)="" G X1
- I 'DIFGCHEK D ^DIFG4 G X1
- I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="D" G X1 ;If no entry found to delete, continue
- I DIFGCHEK,$P(DIFGMO(DIFGMULT),U)="M" S DIFGER=12_U_DIFGY D ERROR^DIFG G X1 ;Lookup for entry failed (no earlier "add" since DIFGFLUS undefined - if DIFGFLUS defined, wouldn't have done ^DIC)
- X1 K DIFGCHEK Q
- ;
- KEY ;DETERMINE @LINK VALUE FROM KEY
- S DIFG("KEY","XREF")=""""_$P($P(DIFGDIX,U,3),"=")_"""",DIFG("KEY","VAL")=""""_$P(DIFGDIX,"=",2)_"""",DIFG("KEY","GLO")=^DIC(DIC,0,"GL")
- S Y=$O(@(DIFG("KEY","GLO")_DIFG("KEY","XREF")_","_DIFG("KEY","VAL")_","""")"))
- I Y="" S Y=-1 S DIFGER=13_U_DIFGY D ERROR^DIFG
- I 'DIFGER S (^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM")),DIFGALNK)=Y,^UTILITY("DIFGX",$J,DIFGSAVE(DIFG,"@NUM"))=X
- Q
- ;
- LINK ;FINDS @NUMBER TO LINK DFN TO FROM LOOKUP
- I $F(DIFGDIX,"@") S DIFGSAVE(DIFG,"@NUM")="@"_+$E(DIFGDIX,$F(DIFGDIX,"@"),99) I $D(^UTILITY("DIFG@",$J,DIFGSAVE(DIFG,"@NUM"))) S DIFGFLUS=""
- ;Line before this checks if DIFG("@NUM") exists. If it exists because it was a modify then don't need to do the lookup.
- ;If exists and is equal to itself (+^UTILITY("DIFG@",$J,"@NUM"))=0, then previous reference to this @link was an add and stll don't do lookup
- Q
- ;
- ARRAY ;SETS EXECUTABLE ARRAY FOR DIC("S")
- F DIFGI=1:1 I '$D(DIFGDIC(DIC,DIFGI)) S DIFGI=DIFGI-1 Q
- S DIFGDIC(DIC,DIFGI)=DIFGDIC(DIC,DIFGI)_+Y,DIFGSVVL(DIFGCT)=+Y
- Q
- ;
- IDENSPEC ;called from ^DIFG3
- S %=DIFGLAGO NEW DIFGLAGO S DIFGLAGO=$S(%=0:0,$D(DIFGENV("LAYGO",DIC,DIFGNUMF(DIFGCT))):1,DIFGHAT'["'":1,1:0) K %
- S DIFGSAVE(DIFG,"HX")=X,X=$P(DIFGDIX,"=",2) X DIFGLINE
- S DIFGSVVL(DIFGCT)="^UTILITY(""DIFG@"","_$J_",""@"_$P(DIFGDIX,"@",2)_""")" D RCR^DIFG3 G:DIFGER X
- S:$S($D(Y):Y<0,1:1) DIFGNOLK="" S X=DIFGSAVE(DIFG,"HX")
- D:$D(DIFGDIC(DIC))&'$D(DIFGNOLK) ARRAY
- X Q
- ;
- DOLO ;called from ^DIFG3
- NEW %,%A
- S %A=$S($D(DIFGMGBL(DIFGMULT)):DIFGMGBL(DIFGMULT),1:^DIC(DIC,0,"GL"))
- F %=0:0 S %=$O(@(%A_"%)")) Q:'% I +^(%,0)=X X DIC("S") I $T S DIFG("FOUND")="",Y=% Q
- I '$D(DIFG("FOUND")) S Y=-1
- Q
- ;
- EOJ ;
- S DIFGEL=DIFGY
- S:$G(DIFGBSE)["^UTILITY" DIFGBSE="~"_$P(DIFGBSE,U,2,99) I 'DIFGER!(DIFGER&($S($D(DIFGBSE):$S(+DIFGBSE:1,1:@($TR($P(DIFGBSE,U),"~","^"))),1:0))) S @("DIFGY="_$TR($P(DIFGBSE,U),"~","^")_"_U_$P(DIFGBSE,U,2,3)")
- E S DIFGY=-1
- I 'DIFGER K DIFGER
- I $D(DIFGREI),($D(DIFGEROR)!'$D(DIFGER)) S DA=DIFGREI,DIK="^DIAR(1.13," D ^DIK K DIK,DA
- K DIFGI,DIFGL,DIFGDIX,DIFGLO,DIFGEND,DIFGMULT,DIFGO,DIFGCT,DIFGEXC,DIFGLINE,DIFGALNK,DIFGSAVX,DIFG,DIFGBSE,DIFGDOL,DIFGNUMF,DIFGPC,DIFGPTER,DIFGVAL,DIFGKEY,DIFGMLND,DIFGDINM,DIFGREI,DIFGCHKG,DIFGEROR,DIFGLC,DIFGENV
- K ^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J),^UTILITY("DIFG",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG5 3636 printed Feb 19, 2025@00:13:56 Page 2
- DIFG5 ;SFISC/DG(OHPRD)-MISC FUNCTIONS ;3/11/93 1:25 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 ;
- CHECKY ;CHECKS Y AFTER DIC CALL
- +1 IF Y>0
- IF DIFGTYP="FILE"!(DIFGTYP="MV FIELD")
- IF $PIECE(DIFGMO(DIFGMULT),U)="L"
- SET ^("MODE")="M"_"^"_$PIECE(^UTILITY("DIFG",$JOB,DIFGINCR,DIFGDIC,"MODE"),U,2)
- +2 IF Y>0
- GOTO X1
- +3 SET DIFGCHEK=0
- IF DIFGTYP="MV FIELD"!(DIFGTYP="FILE")
- SET DIFGCHEK=1
- +4 ;Set X to X^N if internal pointer value was used in lookup, lets ^DIFG7 know if X internal value or not
- IF DIFGCHEK
- IF $PIECE(DIFGMO(DIFGMULT),U)="L"
- IF DIFGTYP'="MV FIELD"
- SET X=$SELECT($DATA(DIFG("ACGRV")):X_"^N",1:X)
- SET DIFGSKIP(DIFGMULT)=""
- DO ^DIFG4
- GOTO X1
- +5 IF DIFGCHEK
- IF $PIECE(DIFGMO(DIFGMULT),U)="L"
- IF DIFGTYP="MV FIELD"
- SET DIFGSKIP(DIFGMULT)=""
- GOTO X1
- +6 IF 'DIFGCHEK
- DO ^DIFG4
- GOTO X1
- +7 ;If no entry found to delete, continue
- IF DIFGCHEK
- IF $PIECE(DIFGMO(DIFGMULT),U)="D"
- GOTO X1
- +8 ;Lookup for entry failed (no earlier "add" since DIFGFLUS undefined - if DIFGFLUS defined, wouldn't have done ^DIC)
- IF DIFGCHEK
- IF $PIECE(DIFGMO(DIFGMULT),U)="M"
- SET DIFGER=12_U_DIFGY
- DO ERROR^DIFG
- GOTO X1
- X1 KILL DIFGCHEK
- QUIT
- +1 ;
- KEY ;DETERMINE @LINK VALUE FROM KEY
- +1 SET DIFG("KEY","XREF")=""""_$PIECE($PIECE(DIFGDIX,U,3),"=")_""""
- SET DIFG("KEY","VAL")=""""_$PIECE(DIFGDIX,"=",2)_""""
- SET DIFG("KEY","GLO")=^DIC(DIC,0,"GL")
- +2 SET Y=$ORDER(@(DIFG("KEY","GLO")_DIFG("KEY","XREF")_","_DIFG("KEY","VAL")_","""")"))
- +3 IF Y=""
- SET Y=-1
- SET DIFGER=13_U_DIFGY
- DO ERROR^DIFG
- +4 IF 'DIFGER
- SET (^UTILITY("DIFG@",$JOB,DIFGSAVE(DIFG,"@NUM")),DIFGALNK)=Y
- SET ^UTILITY("DIFGX",$JOB,DIFGSAVE(DIFG,"@NUM"))=X
- +5 QUIT
- +6 ;
- LINK ;FINDS @NUMBER TO LINK DFN TO FROM LOOKUP
- +1 IF $FIND(DIFGDIX,"@")
- SET DIFGSAVE(DIFG,"@NUM")="@"_+$EXTRACT(DIFGDIX,$FIND(DIFGDIX,"@"),99)
- IF $DATA(^UTILITY("DIFG@",$JOB,DIFGSAVE(DIFG,"@NUM")))
- SET DIFGFLUS=""
- +2 ;Line before this checks if DIFG("@NUM") exists. If it exists because it was a modify then don't need to do the lookup.
- +3 ;If exists and is equal to itself (+^UTILITY("DIFG@",$J,"@NUM"))=0, then previous reference to this @link was an add and stll don't do lookup
- +4 QUIT
- +5 ;
- ARRAY ;SETS EXECUTABLE ARRAY FOR DIC("S")
- +1 FOR DIFGI=1:1
- IF '$DATA(DIFGDIC(DIC,DIFGI))
- SET DIFGI=DIFGI-1
- QUIT
- +2 SET DIFGDIC(DIC,DIFGI)=DIFGDIC(DIC,DIFGI)_+Y
- SET DIFGSVVL(DIFGCT)=+Y
- +3 QUIT
- +4 ;
- IDENSPEC ;called from ^DIFG3
- +1 SET %=DIFGLAGO
- NEW DIFGLAGO
- SET DIFGLAGO=$SELECT(%=0:0,$DATA(DIFGENV("LAYGO",DIC,DIFGNUMF(DIFGCT))):1,DIFGHAT'["'":1,1:0)
- KILL %
- +2 SET DIFGSAVE(DIFG,"HX")=X
- SET X=$PIECE(DIFGDIX,"=",2)
- XECUTE DIFGLINE
- +3 SET DIFGSVVL(DIFGCT)="^UTILITY(""DIFG@"","_$JOB_",""@"_$PIECE(DIFGDIX,"@",2)_""")"
- DO RCR^DIFG3
- if DIFGER
- GOTO X
- +4 if $SELECT($DATA(Y)
- SET DIFGNOLK=""
- SET X=DIFGSAVE(DIFG,"HX")
- +5 if $DATA(DIFGDIC(DIC))&'$DATA(DIFGNOLK)
- DO ARRAY
- X QUIT
- +1 ;
- DOLO ;called from ^DIFG3
- +1 NEW %,%A
- +2 SET %A=$SELECT($DATA(DIFGMGBL(DIFGMULT)):DIFGMGBL(DIFGMULT),1:^DIC(DIC,0,"GL"))
- +3 FOR %=0:0
- SET %=$ORDER(@(%A_"%)"))
- if '%
- QUIT
- IF +^(%,0)=X
- XECUTE DIC("S")
- IF $TEST
- SET DIFG("FOUND")=""
- SET Y=%
- QUIT
- +4 IF '$DATA(DIFG("FOUND"))
- SET Y=-1
- +5 QUIT
- +6 ;
- EOJ ;
- +1 SET DIFGEL=DIFGY
- +2 if $GET(DIFGBSE)["^UTILITY"
- SET DIFGBSE="~"_$PIECE(DIFGBSE,U,2,99)
- IF 'DIFGER!(DIFGER&($SELECT($DATA(DIFGBSE):$SELECT(+DIFGBSE:1,1:@($TRANSLATE($PIECE(DIFGBSE,U),"~","^"))),1:0)))
- SET @("DIFGY="_$TRANSLATE($PIECE(DIFGBSE,U),"~","^")_"_U_$P(DIFGBSE,U,2,3)")
- +3 IF '$TEST
- SET DIFGY=-1
- +4 IF 'DIFGER
- KILL DIFGER
- +5 IF $DATA(DIFGREI)
- IF ($DATA(DIFGEROR)!'$DATA(DIFGER))
- SET DA=DIFGREI
- SET DIK="^DIAR(1.13,"
- DO ^DIK
- KILL DIK,DA
- +6 KILL DIFGI,DIFGL,DIFGDIX,DIFGLO,DIFGEND,DIFGMULT,DIFGO,DIFGCT,DIFGEXC,DIFGLINE,DIFGALNK,DIFGSAVX,DIFG,DIFGBSE,DIFGDOL,DIFGNUMF,DIFGPC,DIFGPTER,DIFGVAL,DIFGKEY,DIFGMLND,DIFGDINM,DIFGREI,DIFGCHKG,DIFGEROR,DIFGLC,DIFGENV
- +7 KILL ^UTILITY("DIFGX",$JOB),^UTILITY("DIFG@",$JOB),^UTILITY("DIFG",$JOB)
- +8 QUIT
