DIFGGSB1 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK PART 2 ;8/12/98 13:16
;;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.
;
BODY S DIFGSB(DILL,"SPSPEC")=0
I $D(DIFG(DILL,"FUNC")),"AL"[DIFG(DILL,"FUNC") I 1
E I $D(DIFG(DILL,"NOKEY"))
E D SPSPEC^DIFGGSB2
Q:DIFGSB(DILL,"SPSPEC")
D P01
D SPEC
D IDENT
Q
;
P01 ; .01 FIELD WHEN IT IS A POINTER
Q:$P(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P"
S DIFGSB(DILL,"FLD")=.01
D SETXY
Q:Y=""
D PTRCHK^DIFGGSB2
Q
;
SPEC ; SPECIFIERS
S DIFGSB(DILL,"SBT")="SPECIFIER:",%=""
F DIFGSB(DILL,"FLD")=0:0 D SPEC2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1
E S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS
K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
K % Q
;
SPEC2 S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD")))
Q
;
IDENT ; IDENTIFIERS
S DIFGSB(DILL,"SBT")="IDENTIFIER:",%=""
N DIXIEN,DIKEY S DIXIEN=0,DIKEY=";"
I $G(DIAR)=4 S DIXIEN=$O(^DD("KEY","AP",DIFG(DILL,"FILE"),"P",0))
F DIFGSB(DILL,"FLD")=0:0 D IDENT2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") D:'$D(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD"))) IDENT3
I '$D(DIFG(DILL,"MUL")) S DR=% D:%'="" FIELDS I 1
E S DR(DIFG(DILL,"FILE"))=% D:%'="" FIELDS
K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
I '$D(DIFG(DILL,"MUL")) K DA,DIC,DR
K %
Q
;
IDENT2 N DIOUT S DIOUT=0
I DIXIEN F D Q:DIOUT!('DIFGSB(DILL,"FLD"))
. S DIFGSB(DILL,"FLD")=$O(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD")))
. Q:'DIFGSB(DILL,"FLD")!(DIFGSB(DILL,"FLD")=.01)
. Q:$O(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD"),0))'=DIFG(DILL,"FILE")
. Q:'$D(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0))
. S DIOUT=1,DIKEY=DIKEY_DIFGSB(DILL,"FLD")_";" Q
Q:DIOUT S DIXIEN=0
F S DIFGSB(DILL,"FLD")=$O(^DD(DIFG(DILL,"FILE"),0,"ID",DIFGSB(DILL,"FLD"))) Q:'DIFGSB(DILL,"FLD") Q:DIKEY'[(";"_DIFGSB(DILL,"FLD"))
Q
;
IDENT3 S %=%_$S(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
Q
;
FIELDS I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"))) D DRFIX
I '$D(DIFG(DILL,"MUL")) Q:DR=""
E Q:DR(DIFG(DILL,"FILE"))=""
K ^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"))
S:'$D(DIFG(DILL,"MUL")) DIC=DIFG(DILL,"FILE"),DA=DIFG(DILL,"FE")
S DIQ(0)="N" D EN^DIQ1 K DIQ
F DIFGSB(DILL,"FLD")=0:0 D FIELDS2 Q:DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD") S X=^(DIFGSB(DILL,"FLD")) D FIELDS3
Q
;
DRFIX ; ADJUST DR FOR MODIFIED/DELETED VALUES
NEW T
I '$D(DIFG(DILL,"MUL")) S T=DR
E S T=DR(DIFG(DILL,"FILE"))
F %=1:1 S X=$P(T,";",%) Q:X="" S %(X)="" I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X)) K %(X) S DIFGSB(DILL,"FLD")=X,X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X) D DRFIX2
S (T,X)=""
F %=0:0 S X=$O(%(X)) Q:X="" S T=T_$S(T="":"",1:";")_X
I '$D(DIFG(DILL,"MUL")) S DR=T
E S DR(DIFG(DILL,"FILE"))=T
Q
;
DRFIX2 NEW %,DR,T
D FIELDS3
Q
;
FIELDS2 S DIFGSB(DILL,"FLD")=$O(^UTILITY("DIQ1",$J,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD")))
Q
;
FIELDS3 Q:X=""
D SETXY
K F,N,P,W
S V=DIFGSB(DILL,"SBT")_$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,1)_U_$S(DIFG("PARM")["N":DIFGSB(DILL,"FLD"),1:"")
S:DIFGSB(DILL,"SBT")["KEY" V=V_U_$P(DIFGSB(DILL,"SPSPEC"),U,2)
S V=V_"="_X
D INCSET^DIFGGU
D:Y'="" PTRCHK^DIFGGSB2
K X,Y
Q
SETXY ; If previously looked up pointer set @LINK
S Y=""
Q:$P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P"
S F=+$P($P(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2),"P",2),W=$P(^(0),U,4),N=$P(W,";",1),P=$P(W,";",2)
I $D(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P")) S Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P") I 1
E S Y=$P(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P)
I $D(^UTILITY("DIFGLINK",$J,F,Y)) S X="@"_^UTILITY("DIFGLINK",$J,F,Y),Y="" Q
S ^UTILITY("DIFGLINK",$J)=$S($D(^UTILITY("DIFGLINK",$J))#2:^UTILITY("DIFGLINK",$J)+1,1:1)
S ^UTILITY("DIFGLINK",$J,F,Y)=^UTILITY("DIFGLINK",$J)
S Y="@"_^UTILITY("DIFGLINK",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFGGSB1 4332 printed Apr 09, 2024@21:48:48 Page 2
DIFGGSB1 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK PART 2 ;8/12/98 13:16
+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 ;
BODY SET DIFGSB(DILL,"SPSPEC")=0
+1 IF $DATA(DIFG(DILL,"FUNC"))
IF "AL"[DIFG(DILL,"FUNC")
IF 1
+2 IF '$TEST
IF $DATA(DIFG(DILL,"NOKEY"))
+3 IF '$TEST
DO SPSPEC^DIFGGSB2
+4 if DIFGSB(DILL,"SPSPEC")
QUIT
+5 DO P01
+6 DO SPEC
+7 DO IDENT
+8 QUIT
+9 ;
P01 ; .01 FIELD WHEN IT IS A POINTER
+1 if $PIECE(^DD(DIFG(DILL,"FILE"),.01,0),U,2)'["P"
QUIT
+2 SET DIFGSB(DILL,"FLD")=.01
+3 DO SETXY
+4 if Y=""
QUIT
+5 DO PTRCHK^DIFGGSB2
+6 QUIT
+7 ;
SPEC ; SPECIFIERS
+1 SET DIFGSB(DILL,"SBT")="SPECIFIER:"
SET %=""
+2 FOR DIFGSB(DILL,"FLD")=0:0
DO SPEC2
if DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")
QUIT
SET %=%_$SELECT(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
+3 IF '$DATA(DIFG(DILL,"MUL"))
SET DR=%
if %'=""
DO FIELDS
IF 1
+4 IF '$TEST
SET DR(DIFG(DILL,"FILE"))=%
if %'=""
DO FIELDS
+5 KILL ^UTILITY("DIQ1",$JOB,DIFG(DILL,"FILE"))
+6 IF '$DATA(DIFG(DILL,"MUL"))
KILL DA,DIC,DR
+7 KILL %
QUIT
+8 ;
SPEC2 SET DIFGSB(DILL,"FLD")=$ORDER(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD")))
+1 QUIT
+2 ;
IDENT ; IDENTIFIERS
+1 SET DIFGSB(DILL,"SBT")="IDENTIFIER:"
SET %=""
+2 NEW DIXIEN,DIKEY
SET DIXIEN=0
SET DIKEY=";"
+3 IF $GET(DIAR)=4
SET DIXIEN=$ORDER(^DD("KEY","AP",DIFG(DILL,"FILE"),"P",0))
+4 FOR DIFGSB(DILL,"FLD")=0:0
DO IDENT2
if DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")
QUIT
if '$DATA(^DD(DIFG(DILL,"FILE"),0,"SP",DIFGSB(DILL,"FLD")))
DO IDENT3
+5 IF '$DATA(DIFG(DILL,"MUL"))
SET DR=%
if %'=""
DO FIELDS
IF 1
+6 IF '$TEST
SET DR(DIFG(DILL,"FILE"))=%
if %'=""
DO FIELDS
+7 KILL ^UTILITY("DIQ1",$JOB,DIFG(DILL,"FILE"))
+8 IF '$DATA(DIFG(DILL,"MUL"))
KILL DA,DIC,DR
+9 KILL %
+10 QUIT
+11 ;
IDENT2 NEW DIOUT
SET DIOUT=0
+1 IF DIXIEN
FOR
Begin DoDot:1
+2 SET DIFGSB(DILL,"FLD")=$ORDER(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD")))
+3 if 'DIFGSB(DILL,"FLD")!(DIFGSB(DILL,"FLD")=.01)
QUIT
+4 if $ORDER(^DD("KEY",DIXIEN,2,"BB",DIFGSB(DILL,"FLD"),0))'=DIFG(DILL,"FILE")
QUIT
+5 if '$DATA(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0))
QUIT
+6 SET DIOUT=1
SET DIKEY=DIKEY_DIFGSB(DILL,"FLD")_";"
QUIT
End DoDot:1
if DIOUT!('DIFGSB(DILL,"FLD"))
QUIT
+7 if DIOUT
QUIT
SET DIXIEN=0
+8 FOR
SET DIFGSB(DILL,"FLD")=$ORDER(^DD(DIFG(DILL,"FILE"),0,"ID",DIFGSB(DILL,"FLD")))
if 'DIFGSB(DILL,"FLD")
QUIT
if DIKEY'[(";"_DIFGSB(DILL,"FLD"))
QUIT
+9 QUIT
+10 ;
IDENT3 SET %=%_$SELECT(%="":DIFGSB(DILL,"FLD"),1:";"_DIFGSB(DILL,"FLD"))
+1 QUIT
+2 ;
FIELDS IF $DATA(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE")))
DO DRFIX
+1 IF '$DATA(DIFG(DILL,"MUL"))
if DR=""
QUIT
+2 IF '$TEST
if DR(DIFG(DILL,"FILE"))=""
QUIT
+3 KILL ^UTILITY("DIQ1",$JOB,DIFG(DILL,"FILE"))
+4 if '$DATA(DIFG(DILL,"MUL"))
SET DIC=DIFG(DILL,"FILE")
SET DA=DIFG(DILL,"FE")
+5 SET DIQ(0)="N"
DO EN^DIQ1
KILL DIQ
+6 FOR DIFGSB(DILL,"FLD")=0:0
DO FIELDS2
if DIFGSB(DILL,"FLD")'=+DIFGSB(DILL,"FLD")
QUIT
SET X=^(DIFGSB(DILL,"FLD"))
DO FIELDS3
+7 QUIT
+8 ;
DRFIX ; ADJUST DR FOR MODIFIED/DELETED VALUES
+1 NEW T
+2 IF '$DATA(DIFG(DILL,"MUL"))
SET T=DR
+3 IF '$TEST
SET T=DR(DIFG(DILL,"FILE"))
+4 FOR %=1:1
SET X=$PIECE(T,";",%)
if X=""
QUIT
SET %(X)=""
IF $DATA(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X))
KILL %(X)
SET DIFGSB(DILL,"FLD")=X
SET X=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),X)
DO DRFIX2
+5 SET (T,X)=""
+6 FOR %=0:0
SET X=$ORDER(%(X))
if X=""
QUIT
SET T=T_$SELECT(T="":"",1:";")_X
+7 IF '$DATA(DIFG(DILL,"MUL"))
SET DR=T
+8 IF '$TEST
SET DR(DIFG(DILL,"FILE"))=T
+9 QUIT
+10 ;
DRFIX2 NEW %,DR,T
+1 DO FIELDS3
+2 QUIT
+3 ;
FIELDS2 SET DIFGSB(DILL,"FLD")=$ORDER(^UTILITY("DIQ1",$JOB,DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD")))
+1 QUIT
+2 ;
FIELDS3 if X=""
QUIT
+1 DO SETXY
+2 KILL F,N,P,W
+3 SET V=DIFGSB(DILL,"SBT")_$PIECE(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,1)_U_$SELECT(DIFG("PARM")["N":DIFGSB(DILL,"FLD"),1:"")
+4 if DIFGSB(DILL,"SBT")["KEY"
SET V=V_U_$PIECE(DIFGSB(DILL,"SPSPEC"),U,2)
+5 SET V=V_"="_X
+6 DO INCSET^DIFGGU
+7 if Y'=""
DO PTRCHK^DIFGGSB2
+8 KILL X,Y
+9 QUIT
SETXY ; If previously looked up pointer set @LINK
+1 SET Y=""
+2 if $PIECE(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2)'["P"
QUIT
+3 SET F=+$PIECE($PIECE(^DD(DIFG(DILL,"FILE"),DIFGSB(DILL,"FLD"),0),U,2),"P",2)
SET W=$PIECE(^(0),U,4)
SET N=$PIECE(W,";",1)
SET P=$PIECE(W,";",2)
+4 IF $DATA(DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P"))
SET Y=DIFGGU(DIFG(DILL,"FILE"),DIFG(DILL,"FE"),DIFGSB(DILL,"FLD"),"P")
IF 1
+5 IF '$TEST
SET Y=$PIECE(@(DIFG(DILL,"FGBL")_DIFG(DILL,"FE")_",N)"),U,P)
+6 IF $DATA(^UTILITY("DIFGLINK",$JOB,F,Y))
SET X="@"_^UTILITY("DIFGLINK",$JOB,F,Y)
SET Y=""
QUIT
+7 SET ^UTILITY("DIFGLINK",$JOB)=$SELECT($DATA(^UTILITY("DIFGLINK",$JOB))#2:^UTILITY("DIFGLINK",$JOB)+1,1:1)
+8 SET ^UTILITY("DIFGLINK",$JOB,F,Y)=^UTILITY("DIFGLINK",$JOB)
+9 SET Y="@"_^UTILITY("DIFGLINK",$JOB)
+10 QUIT
