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 Apr 09, 2024@21:48:31 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
