- DIFG0 ;SFISC/DG(OHPRD)-SETS UP DIC("S"), EVALS 1ST LINE OF A (SUB)FILE ;05/25/93 10:17 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.
- ;
- NDPC ;DETERMINE NODE,PIECE FOR DATA FOR THIS FIELD
- S DIFGCT=DIFGCT+1
- S:DIFG("PARAM")["N" DIFGNUMF(DIFGCT)=+$P(DIFGDIX,"^",2),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
- I '$D(DIFGPC(DIFGCT)) S DIFGNUMF(DIFGCT)=$O(^DD(DIC,"B",$P($P(DIFGDIX,"^"),":",2),"")),DIFGPC(DIFGCT)=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
- S DIFGHAT=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,2) I DIFGHAT["P",$P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S DIFGPTER(DIFGCT)=""
- D DICS
- D GETVAL
- Q
- ;
- DICS ;SET DIC("S")
- I $P(DIFGPC(DIFGCT),";",2)'["," S DIFGDOL="$P(^($P(DIFGPC("_DIFGCT_"),"";"")),U,$P(DIFGPC("_DIFGCT_"),"";"",2))="
- E S DIFGDOL="$E(^($P(DIFGPC("_DIFGCT_"),"";"")),$P(DIFGPC("_DIFGCT_"),"";"",2))="
- I '$D(DIFGDIC(DIC)) S DIFGDICS(DIC)=1
- E S DIFGDICS(DIC)=DIFGDICS(DIC)+1
- S DIFGDIC(DIC,DIFGDICS(DIC))="I "_DIFGDOL_$S($D(DIFGPTER(DIFGCT)):"",1:"DIFGVAL("_DIFGCT_")")
- Q
- ;
- GETVAL ;GETS VALUE TO RIGHT OF EQUAL SIGN
- I $P(DIFGDIX,"=",2)'?1"@"1N.N.1"E" S (DIFGVAL(DIFGCT),^UTILITY("DIFGX",$J,DIFGCT))=$P(DIFGDIX,"=",2) D:DIFGHAT["S" SETCODES D:DIFGHAT["D" DATE I 1
- E S DIFGVAL(DIFGCT)=^UTILITY("DIFG@",$J,$P(DIFGDIX,"=",2)) S:$D(^UTILITY("DIFGX",$J,$P(DIFGDIX,"=",2))) ^UTILITY("DIFGX",$J,DIFGCT)=^($P(DIFGDIX,"=",2))
- X1 Q
- ;
- SETCODES ;DETERMINE INTERNAL VALUE IF FIELD ATTRIBUTE IS SET OF CODES
- I $P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3)[":"_DIFGVAL(DIFGCT)_";" S DIFGSET=$P(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3),%=$P(DIFGSET,":"_DIFGVAL(DIFGCT)_";"),%A=$L(%,";"),DIFGVAL(DIFGCT)=$P(%,";",%A)
- K DIFGSET,%,%A
- Q
- ;
- DATE ;GET INTERNAL FORM OF DATE
- S DIFGSAVX=X,%DT="T",X=$P(DIFGDIX,"=",2) D ^%DT S DIFGVAL(DIFGCT)=Y,X=DIFGSAVX
- I Y=-1 S DIFGER=5_U_DIFGY D ERROR^DIFG
- Q
- ;
- BASE ;BASE FILE ENTRY LINE
- K DIFGXRF(DIFGMULT)
- I $P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N1"E" S (DIFGALNK,Y)=^UTILITY("DIFG@",$J,$E($P($P(DIFGDIX,U,3),"=",2),1,$L($P($P(DIFGDIX,U,3),"=",2))-1)),DIFGFLUS="" S:'Y DIFGSKIP(DIFGMULT)="" S DIFG("NOLKUP")=""
- I '$D(DIFG("NOLKUP")) S X=$S($P($P(DIFGDIX,U,3),"=",2)?1"@"1N.N:"`"_$S(^UTILITY("DIFG@",$J,$P($P(DIFGDIX,U,3),"=",2))["^UTILITY":"^"_$P(^($P($P(DIFGDIX,U,3),"=",2)),U,2),1:$P(^($P($P(DIFGDIX,U,3),"=",2)),U)),1:$P($P(DIFGDIX,U,3),"=",2))
- I '$D(DIC) S DIC=$S(+$P(DIFGDIX,U,2):+$P(DIFGDIX,U,2),$D(^DIC("B",$P(DIFGDIX,U))):$O(^DIC("B",$P(DIFGDIX,U),"")),1:"") I DIC S:'$D(^DIC(DIC)) DIC=""
- I 'DIC S DIFGER=20_U_DIFGY D ERROR^DIFG
- I $P(DIFGDIX,U,4)]"" S DIFGXRF(DIFGMULT)=$P(DIFGDIX,U,4)
- Q
- ;
- FUNC ;CHECKS FUNCTION ON BASE ENTRY LINE
- S DIFGO=DIFGO+1
- S DIFGINCR=DIFGO
- S %=$P(DIFGDIX,U,3),%=$P(%,"="),^UTILITY("DIFG",$J,DIFGINCR,DIC,"MODE")=$S(%?1A:%,1:"L")_"^"_DIFGY S DIFGMO(DIFGMULT)=$P(^("MODE"),U)_"^"_DIC
- K %
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG0 3070 printed Feb 19, 2025@00:13:48 Page 2
- DIFG0 ;SFISC/DG(OHPRD)-SETS UP DIC("S"), EVALS 1ST LINE OF A (SUB)FILE ;05/25/93 10:17 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 ;
- NDPC ;DETERMINE NODE,PIECE FOR DATA FOR THIS FIELD
- +1 SET DIFGCT=DIFGCT+1
- +2 if DIFG("PARAM")["N"
- SET DIFGNUMF(DIFGCT)=+$PIECE(DIFGDIX,"^",2)
- SET DIFGPC(DIFGCT)=$PIECE(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
- +3 IF '$DATA(DIFGPC(DIFGCT))
- SET DIFGNUMF(DIFGCT)=$ORDER(^DD(DIC,"B",$PIECE($PIECE(DIFGDIX,"^"),":",2),""))
- SET DIFGPC(DIFGCT)=$PIECE(^DD(DIC,DIFGNUMF(DIFGCT),0),"^",4)
- +4 SET DIFGHAT=$PIECE(^DD(DIC,DIFGNUMF(DIFGCT),0),U,2)
- IF DIFGHAT["P"
- IF $PIECE(DIFGDIX,"=",2)'?1"@"1N.N.1"E"
- SET DIFGPTER(DIFGCT)=""
- +5 DO DICS
- +6 DO GETVAL
- +7 QUIT
- +8 ;
- DICS ;SET DIC("S")
- +1 IF $PIECE(DIFGPC(DIFGCT),";",2)'[","
- SET DIFGDOL="$P(^($P(DIFGPC("_DIFGCT_"),"";"")),U,$P(DIFGPC("_DIFGCT_"),"";"",2))="
- +2 IF '$TEST
- SET DIFGDOL="$E(^($P(DIFGPC("_DIFGCT_"),"";"")),$P(DIFGPC("_DIFGCT_"),"";"",2))="
- +3 IF '$DATA(DIFGDIC(DIC))
- SET DIFGDICS(DIC)=1
- +4 IF '$TEST
- SET DIFGDICS(DIC)=DIFGDICS(DIC)+1
- +5 SET DIFGDIC(DIC,DIFGDICS(DIC))="I "_DIFGDOL_$SELECT($DATA(DIFGPTER(DIFGCT)):"",1:"DIFGVAL("_DIFGCT_")")
- +6 QUIT
- +7 ;
- GETVAL ;GETS VALUE TO RIGHT OF EQUAL SIGN
- +1 IF $PIECE(DIFGDIX,"=",2)'?1"@"1N.N.1"E"
- SET (DIFGVAL(DIFGCT),^UTILITY("DIFGX",$JOB,DIFGCT))=$PIECE(DIFGDIX,"=",2)
- if DIFGHAT["S"
- DO SETCODES
- if DIFGHAT["D"
- DO DATE
- IF 1
- +2 IF '$TEST
- SET DIFGVAL(DIFGCT)=^UTILITY("DIFG@",$JOB,$PIECE(DIFGDIX,"=",2))
- if $DATA(^UTILITY("DIFGX",$JOB,$PIECE(DIFGDIX,"=",2)))
- SET ^UTILITY("DIFGX",$JOB,DIFGCT)=^($PIECE(DIFGDIX,"=",2))
- X1 QUIT
- +1 ;
- SETCODES ;DETERMINE INTERNAL VALUE IF FIELD ATTRIBUTE IS SET OF CODES
- +1 IF $PIECE(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3)[":"_DIFGVAL(DIFGCT)_";"
- SET DIFGSET=$PIECE(^DD(DIC,DIFGNUMF(DIFGCT),0),U,3)
- SET %=$PIECE(DIFGSET,":"_DIFGVAL(DIFGCT)_";")
- SET %A=$LENGTH(%,";")
- SET DIFGVAL(DIFGCT)=$PIECE(%,";",%A)
- +2 KILL DIFGSET,%,%A
- +3 QUIT
- +4 ;
- DATE ;GET INTERNAL FORM OF DATE
- +1 SET DIFGSAVX=X
- SET %DT="T"
- SET X=$PIECE(DIFGDIX,"=",2)
- DO ^%DT
- SET DIFGVAL(DIFGCT)=Y
- SET X=DIFGSAVX
- +2 IF Y=-1
- SET DIFGER=5_U_DIFGY
- DO ERROR^DIFG
- +3 QUIT
- +4 ;
- BASE ;BASE FILE ENTRY LINE
- +1 KILL DIFGXRF(DIFGMULT)
- +2 IF $PIECE($PIECE(DIFGDIX,U,3),"=",2)?1"@"1N.N1"E"
- SET (DIFGALNK,Y)=^UTILITY("DIFG@",$JOB,$EXTRACT($PIECE($PIECE(DIFGDIX,U,3),"=",2),1,$LENGTH($PIECE($PIECE(DIFGDIX,U,3),"=",2))-1))
- SET DIFGFLUS=""
- if 'Y
- SET DIFGSKIP(DIFGMULT)=""
- SET DIFG("NOLKUP")=""
- +3 IF '$DATA(DIFG("NOLKUP"))
- SET X=$SELECT($PIECE($PIECE(DIFGDIX,U,3),"=",2)?1"@"1N.N:"`"_$SELECT(^UTILITY("DIFG@",$JOB,$PIECE($PIECE(DIFGDIX,U,3),"=",2))["^UTILITY":"^"_$PIECE(^($PIECE(...
- ... $PIECE(DIFGDIX,U,3),"=",2)),U,2),1:$PIECE(^($PIECE($PIECE(DIFGDIX,U,3),"=",2)),U)),1:$PIECE($PIECE(DIFGDIX,U,3),"=",2))
- +4 IF '$DATA(DIC)
- SET DIC=$SELECT(+$PIECE(DIFGDIX,U,2):+$PIECE(DIFGDIX,U,2),$DATA(^DIC("B",$PIECE(DIFGDIX,U))):$ORDER(^DIC("B",$PIECE(DIFGDIX,U),"")),1:"")
- IF DIC
- if '$DATA(^DIC(DIC))
- SET DIC=""
- +5 IF 'DIC
- SET DIFGER=20_U_DIFGY
- DO ERROR^DIFG
- +6 IF $PIECE(DIFGDIX,U,4)]""
- SET DIFGXRF(DIFGMULT)=$PIECE(DIFGDIX,U,4)
- +7 QUIT
- +8 ;
- FUNC ;CHECKS FUNCTION ON BASE ENTRY LINE
- +1 SET DIFGO=DIFGO+1
- +2 SET DIFGINCR=DIFGO
- +3 SET %=$PIECE(DIFGDIX,U,3)
- SET %=$PIECE(%,"=")
- SET ^UTILITY("DIFG",$JOB,DIFGINCR,DIC,"MODE")=$SELECT(%?1A:%,1:"L")_"^"_DIFGY
- SET DIFGMO(DIFGMULT)=$PIECE(^("MODE"),U)_"^"_DIC
- +4 KILL %
- +5 QUIT
- +6 ;