DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93 9:45 AM
;;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.
;
; DIFGER values: 1 = required variable not passed
; 2 = variable form invalid
; 3 = variable content invalid
;
INIT ; INITIALIZATION
K ^UTILITY("DIFG",$J),^UTILITY("DIFGLINK",$J)
D SET1,REQ Q:DIFG("QFLG")
D OPT Q:DIFG("QFLG")
D FIRST
Q
;
SET1 ; MISC SETS # 1
S DIFGI=0,DILL=1 K DIFGER S U="^",DIFG("QFLG")=0
Q
;
REQ ;
;
FE I '$D(DIFG("FE")) S DIFG("QFLG")=1 Q
I DIFG("FE")'=+DIFG("FE") S DIFG("QFLG")=2 Q
FUNC I '$D(DIFG("FUNC")) S DIFG("QFLG")="1" Q
I DIFG("FUNC")="" S DIFG("QFLG")=2 Q
I "AMLD"'[DIFG("FUNC") S DIFG("QFLG")=3 Q
FGT I '$D(DIFGT) S DIFG("QFLG")=1 Q
I DIFGT'=+DIFGT S DIFG("QFLG")=2 Q
I '$D(^DIPT(DIFGT,0)) S DIFG("QFLG")=3 Q
Q
;
OPT ;
;
FGR I '$D(DIFG("FGR")) S DIFG("FGR")="^UTILITY(""DIFG"",$J,"
S X=DIFG("FGR")
I "(,"'[$E(X,$L(X)) S DIFG("QFLG")=2 Q
I $P(X,"(")["DIFG" S DIFG("QFLG")=3 Q
LC I $D(DILC),DILC'=+DILC S DIFG("QFLG")=2 Q
S:'$D(DILC) DILC=0
PARM S:'$D(DIFG("PARM")) DIFG("PARM")="N"
TAB I $D(DITAB),DITAB'=+DITAB S DIFG("QFLG")=2 Q
S:'$D(DITAB) DITAB=0
FUNCSFT I $D(DIFG("FUNC SFT")) F X=0:0 S X=$O(DIFG("FUNC SFT",X)) Q:X'=+X D FUNCSFT2 Q:DIFG("QFLG")
Q
;
FUNCSFT2 S Y=DIFG("FUNC SFT",X)
I Y="" S DIFG("QFLG")=2 Q
I "AMLD"'[Y S DIFG("QFLG")=3 Q
Q
;
FIRST ; GET PRIMARY FILE VARIABLES
S DIFGI=$O(^DIPT(DIFGT,1,DIFGI)) Q:DIFGI'=+DIFGI S X=^(DIFGI,0)
D FVARS
I '$D(@(DIFG(DILL,"FGBL")_DIFG("FE")_",0)")) S DIFG("QFLG")=3 Q
Q
;
FVARS ; SETUP FILE VARIABLES
S DILL=$P(X,U,2),DITAB=2*(DILL-1),DIFG(DILL,"FILE")=+X
S DIFG(DILL,"FNAME")=$O(^DD(DIFG(DILL,"FILE"),0,"NM",0))
I DILL=1 S DIFG(DILL,"FE")=DIFG("FE"),DIFG(DILL,"FUNC")=DIFG("FUNC")
E S DIFG(DILL,"FUNC")=DIFG(DILL-1,"FUNC")
I $D(DIFG("FUNC SFT",DIFG(DILL,"FILE"))) S DIFG(DILL,"FUNC")=DIFG("FUNC SFT",DIFG(DILL,"FILE"))
I $P(X,U,4)=1 S DIFG(DILL,"FE")=DIFG(DILL-1,"FE") ; dinum back pointer
S DIFG(DILL,"XREF")=$S($P(X,U,4)=4:$P(X,U,7),1:$P(X,U,4)),%=$P(X,U,5) ;Back pointer if $P=4 X-ref in $P7
I $E(%,$L(%))=":" S DIFG(DILL,"NAV")=1 I $P(X,U,4)=2 S DIFG(DILL,"NAV")=2 D DIRECT K %,Y
I $P(X,U,4)=3 S %=$P(X,U,3),%=$O(^DD(%,"SB",+X,0)),%=^DD(+$P(X,U,3),%,0),%=$P($P(^(0),U,4),";") S:+%'=% %=""""_%_"""" S DIFG(DILL,"FGBL")=DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%_"," K DIFG(DILL,"NAV") Q ; multiple
S DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL")
D:$P(X,U,4)=5 LOOKUP
Q
;
DIRECT ;DIRECT POINTER
S DIFG(DILL,"FE")=0,%=$P(%,":")
S:'$D(^DD(DIFG(DILL-1,"FILE"),"B",%)) %=$O(^(%))
S %=$O(^DD(DIFG(DILL-1,"FILE"),"B",%,0))
Q:%'=+%
S Y=$P(^DD(DIFG(DILL-1,"FILE"),%,0),U,4),%("N")=$P(Y,";"),%("P")=$P(Y,";",2) S:+%("N")'=%("N") %("N")=""""_%("N")_""""
I $D(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%("N")_")")) S Y=@("^("_%("N")_")"),DIFG(DILL,"FE")=$P(Y,U,%("P"))
Q
;
LOOKUP ;COMPUTED FIELD LOOKUP FOR FILE SHIFT
S DIFG(DILL,"FE")=""
S %=$O(^DD(DIFG(DILL,"FILE"),"B",$P($P(X,U,5),":"),0))
Q:'%
X $P(^DD(DIFG(DILL,"FILE"),%,0),U,5,99)
I $D(X) S DIFG(DILL,"FE")=$S(X?1"`"1N.N:$E(X,2,99),X?1N.N:X,1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGGI 3452 printed Dec 13, 2024@02:47:50 Page 2
DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93 9:45 AM
+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 ; DIFGER values: 1 = required variable not passed
+8 ; 2 = variable form invalid
+9 ; 3 = variable content invalid
+10 ;
INIT ; INITIALIZATION
+1 KILL ^UTILITY("DIFG",$JOB),^UTILITY("DIFGLINK",$JOB)
+2 DO SET1
DO REQ
if DIFG("QFLG")
QUIT
+3 DO OPT
if DIFG("QFLG")
QUIT
+4 DO FIRST
+5 QUIT
+6 ;
SET1 ; MISC SETS # 1
+1 SET DIFGI=0
SET DILL=1
KILL DIFGER
SET U="^"
SET DIFG("QFLG")=0
+2 QUIT
+3 ;
REQ ;
+1 ;
FE IF '$DATA(DIFG("FE"))
SET DIFG("QFLG")=1
QUIT
+1 IF DIFG("FE")'=+DIFG("FE")
SET DIFG("QFLG")=2
QUIT
FUNC IF '$DATA(DIFG("FUNC"))
SET DIFG("QFLG")="1"
QUIT
+1 IF DIFG("FUNC")=""
SET DIFG("QFLG")=2
QUIT
+2 IF "AMLD"'[DIFG("FUNC")
SET DIFG("QFLG")=3
QUIT
FGT IF '$DATA(DIFGT)
SET DIFG("QFLG")=1
QUIT
+1 IF DIFGT'=+DIFGT
SET DIFG("QFLG")=2
QUIT
+2 IF '$DATA(^DIPT(DIFGT,0))
SET DIFG("QFLG")=3
QUIT
+3 QUIT
+4 ;
OPT ;
+1 ;
FGR IF '$DATA(DIFG("FGR"))
SET DIFG("FGR")="^UTILITY(""DIFG"",$J,"
+1 SET X=DIFG("FGR")
+2 IF "(,"'[$EXTRACT(X,$LENGTH(X))
SET DIFG("QFLG")=2
QUIT
+3 IF $PIECE(X,"(")["DIFG"
SET DIFG("QFLG")=3
QUIT
LC IF $DATA(DILC)
IF DILC'=+DILC
SET DIFG("QFLG")=2
QUIT
+1 if '$DATA(DILC)
SET DILC=0
PARM if '$DATA(DIFG("PARM"))
SET DIFG("PARM")="N"
TAB IF $DATA(DITAB)
IF DITAB'=+DITAB
SET DIFG("QFLG")=2
QUIT
+1 if '$DATA(DITAB)
SET DITAB=0
FUNCSFT IF $DATA(DIFG("FUNC SFT"))
FOR X=0:0
SET X=$ORDER(DIFG("FUNC SFT",X))
if X'=+X
QUIT
DO FUNCSFT2
if DIFG("QFLG")
QUIT
+1 QUIT
+2 ;
FUNCSFT2 SET Y=DIFG("FUNC SFT",X)
+1 IF Y=""
SET DIFG("QFLG")=2
QUIT
+2 IF "AMLD"'[Y
SET DIFG("QFLG")=3
QUIT
+3 QUIT
+4 ;
FIRST ; GET PRIMARY FILE VARIABLES
+1 SET DIFGI=$ORDER(^DIPT(DIFGT,1,DIFGI))
if DIFGI'=+DIFGI
QUIT
SET X=^(DIFGI,0)
+2 DO FVARS
+3 IF '$DATA(@(DIFG(DILL,"FGBL")_DIFG("FE")_",0)"))
SET DIFG("QFLG")=3
QUIT
+4 QUIT
+5 ;
FVARS ; SETUP FILE VARIABLES
+1 SET DILL=$PIECE(X,U,2)
SET DITAB=2*(DILL-1)
SET DIFG(DILL,"FILE")=+X
+2 SET DIFG(DILL,"FNAME")=$ORDER(^DD(DIFG(DILL,"FILE"),0,"NM",0))
+3 IF DILL=1
SET DIFG(DILL,"FE")=DIFG("FE")
SET DIFG(DILL,"FUNC")=DIFG("FUNC")
+4 IF '$TEST
SET DIFG(DILL,"FUNC")=DIFG(DILL-1,"FUNC")
+5 IF $DATA(DIFG("FUNC SFT",DIFG(DILL,"FILE")))
SET DIFG(DILL,"FUNC")=DIFG("FUNC SFT",DIFG(DILL,"FILE"))
+6 ; dinum back pointer
IF $PIECE(X,U,4)=1
SET DIFG(DILL,"FE")=DIFG(DILL-1,"FE")
+7 ;Back pointer if $P=4 X-ref in $P7
SET DIFG(DILL,"XREF")=$SELECT($PIECE(X,U,4)=4:$PIECE(X,U,7),1:$PIECE(X,U,4))
SET %=$PIECE(X,U,5)
+8 IF $EXTRACT(%,$LENGTH(%))=":"
SET DIFG(DILL,"NAV")=1
IF $PIECE(X,U,4)=2
SET DIFG(DILL,"NAV")=2
DO DIRECT
KILL %,Y
+9 ; multiple
IF $PIECE(X,U,4)=3
SET %=$PIECE(X,U,3)
SET %=$ORDER(^DD(%,"SB",+X,0))
SET %=^DD(+$PIECE(X,U,3),%,0)
SET %=$PIECE($PIECE(^(0),U,4),";")
if +%'=%
SET %=""""_%_""""
SET DIFG(DILL,"FGBL")=DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%_","
KILL DIFG(DILL,"NAV")
QUIT
+10 SET DIFG(DILL,"FGBL")=^DIC(DIFG(DILL,"FILE"),0,"GL")
+11 if $PIECE(X,U,4)=5
DO LOOKUP
+12 QUIT
+13 ;
DIRECT ;DIRECT POINTER
+1 SET DIFG(DILL,"FE")=0
SET %=$PIECE(%,":")
+2 if '$DATA(^DD(DIFG(DILL-1,"FILE"),"B",%))
SET %=$ORDER(^(%))
+3 SET %=$ORDER(^DD(DIFG(DILL-1,"FILE"),"B",%,0))
+4 if %'=+%
QUIT
+5 SET Y=$PIECE(^DD(DIFG(DILL-1,"FILE"),%,0),U,4)
SET %("N")=$PIECE(Y,";")
SET %("P")=$PIECE(Y,";",2)
if +%("N")'=%("N")
SET %("N")=""""_%("N")_""""
+6 IF $DATA(@(DIFG(DILL-1,"FGBL")_DIFG(DILL-1,"FE")_","_%("N")_")"))
SET Y=@("^("_%("N")_")")
SET DIFG(DILL,"FE")=$PIECE(Y,U,%("P"))
+7 QUIT
+8 ;
LOOKUP ;COMPUTED FIELD LOOKUP FOR FILE SHIFT
+1 SET DIFG(DILL,"FE")=""
+2 SET %=$ORDER(^DD(DIFG(DILL,"FILE"),"B",$PIECE($PIECE(X,U,5),":"),0))
+3 if '%
QUIT
+4 XECUTE $PIECE(^DD(DIFG(DILL,"FILE"),%,0),U,5,99)
+5 IF $DATA(X)
SET DIFG(DILL,"FE")=$SELECT(X?1"`"1N.N:$EXTRACT(X,2,99),X?1N.N:X,1:"")
+6 QUIT
