- DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93 9:45 AM
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ; 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
- DIFGGI ;SFISC/XAK,EDE(OHPRD)-FILEGRAM INITIALIZATION ;1/19/93 9:45 AM
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ; DIFGER values: 1 = required variable not passed
- +4 ; 2 = variable form invalid
- +5 ; 3 = variable content invalid
- +6 ;
- 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
