source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIFGGSB1.m@ 700

DIFGGSB1 ;SFISC/XAK,EDE(OHPRD)-FILEGRAM SPECIAL BLOCK PART 2 ;8/12/98  13:16
 ;;22.0;VA FileMan;;Mar 30, 1999
 ;Per VHA Directive 10-93-142, this routine should not be modified.
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