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