- DIFG ;SFISC/DG(OHPRD)-FILEGRAM INSTALLER ;10/9/95 05:50
- ;;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.
- ;
- I $D(DIFGREI) S DIFGLO="^DIAR(1.13,"_DIFGREI_",21," K DIFGLC
- I '$D(DIFGLO) S DIFGER="1^0" Q
- I $E(DIFGLO,$L(DIFGLO))=","!($E(DIFGLO,$L(DIFGLO))="(")
- E S DIFGER="1.25^0" K DIFGLO,DIFGREI Q
- S DIFGCHKG=$S($E(DIFGLO,$L(DIFGLO))=",":$E(DIFGLO,1,$L(DIFGLO)-1)_")",1:$P(DIFGLO,"("))
- I '$D(@(DIFGCHKG)) S DIFGER="1.5^0" K DIFGCHKG,DIFGLO,DIFGREI Q
- D INIT,START,KILLVAR,EOJ^DIFG5
- Q
- ;
- INIT S U="^"
- K ^UTILITY("DIFG",$J),^UTILITY("DIFGFG",$J),^UTILITY("DIFGX",$J),^UTILITY("DIFG@",$J)
- D DT^DICRW
- S DIFGEXC="F DIFGL=1:1 Q:$E(DIFGDIX,DIFGL)'="" """
- S DIFGLINE="S DIFGY=$O("_DIFGLO_"DIFGY)) Q:DIFGY'>0 S DIFGDIX=^(DIFGY,0) X DIFGEXC S DIFGDIX=$E(DIFGDIX,DIFGL,255)"
- Q
- ;
- START S (DIFG,DIFGER,DIFGMULT,DIFGEND,DIFGO,DIFGCT,DIFGADD,DIFGTYPE,DIFGINCR,DIFGNDC)=0,DIFGY=$S('$D(DIFGLC):.9999,1:DIFGLC-.0001),DIFGNODL=1 D FILEGRAM,KILLVAR
- D:'DIFGER ^DIFG6
- Q
- ;
- FILEGRAM X DIFGLINE
- I $P(DIFGDIX,"^")'="$DAT" S DIFGER=2_U_DIFGY D ERROR G X1
- S DIFG("PARAM")=$P(DIFGDIX,U,4)
- X DIFGLINE
- A I $P(DIFGDIX,":")="ENVIRONMENT" S @($P($P(DIFGDIX,":",2),"=")_"="_$P(DIFGDIX,"=",2)) X DIFGLINE G A
- D BASEFILE^DIFG0B G:DIFGER X1
- D FILE
- X1 Q
- ;
- FILE F DIFGL=0:0 X DIFGLINE D EVAL I DIFGTYPE="TERM"!DIFGER S DIFGTYPE="" Q
- Q
- ;
- EVAL D GETTYPE
- I DIFGER G X3
- I DIFGTYPE="TERM" G X3
- I DIFGTYPE="MV FIELD" D ^DIFG2 G X3
- I DIFGTYPE="SV FIELD" D ^DIFG1 G X3
- I DIFGTYPE="WP FIELD" D ^DIFG1 G X3
- I DIFGTYPE="SWITCH" D SWITCH^DIFG0A G X3
- I DIFGTYPE="SKIP" ;computed field, do not process
- X3 Q
- ;
- GETTYPE I DIFGDIX="^"!(DIFGDIX=":")!(DIFGDIX="$END DAT") S DIFGTYPE="TERM" G X4
- I $P(DIFGDIX,U)="$DAT"!($P(DIFGDIX,":")="$DAT") S DIFGER=3_U_DIFGY,DIFGEND=1,DIFGTYPE="TERM" D ERROR G X4
- I $P(DIFGDIX,U,2)[":" S DIFGSTRT=$F(DIFGDIX,"^"),DIFGFIND=$E(DIFGDIX,DIFGSTRT,245) I $E(DIFGFIND,$F(DIFGFIND,":"))="^" S DIFGTYPE="SWITCH" G X4
- D EVALFLD
- X4 Q
- ;
- EVALFLD I DIFG("PARAM")["N" S DIFGNUM=+$P(DIFGDIX,U,2)
- E S DIFGNUM=$O(^DD(DIC,"B",$P(DIFGDIX,U),""))
- I '$D(^DD(DIC,DIFGNUM)) S DIFGER=4_U_DIFGY D ERROR G X5
- I $P(^DD(DIC,DIFGNUM,0),U,2)["C" S DIFGTYPE="SKIP" G X5
- I +$P(^DD(DIC,DIFGNUM,0),U,2) S DIFGMLND=^DD(DIC,DIFGNUM,0),DIFGFLDN=DIFGNUM,DIFGNUM=+$P(DIFGMLND,U,2) S DIFGTYPE=$S($P(^DD(DIFGNUM,.01,0),U,2)'["W":"MV FIELD",1:"WP FIELD")
- E S DIFGTYPE="SV FIELD"
- X5 Q
- ;
- ERROR NEW DA,DIC,DIE,X,Y,DO
- S X=$P(DIFGER,U,2),DIC("DR")=".02////"_$P(DIFGER,U),DIC="^DIAR(1.13,",DIC(0)="FL" D FILE^DICN S DIFGLOG=$S(Y>0:+Y,1:-1) G:DIFGLOG=-1 X6
- S B=0 F A=$S($D(DIFGLC):DIFGLC-.0001,1:0):0 S A=$O(@(DIFGLO_"A)")) Q:'A S B=B+1,^DIAR(1.13,+Y,21,B,0)=$S('$D(^UTILITY("DIFGFG",$J,A)):@(DIFGLO_"A,0)"),1:^UTILITY("DIFGFG",$J,A)) S:A=$P(DIFGER,U,2) $P(DIFGER,U,2)=B Q:^(0)["$END DAT"
- S ^DIAR(1.13,+Y,21,0)="^^"_B_"^"_B_"^"_DT
- S DIE="^DIAR(1.13,",DA=DIFGLOG,DR=".01///"_$P(DIFGER,U,2) D ^DIE K DIE,DA,DR
- S DIFGEROR=""
- X6 K A,B Q
- ;
- KILLVAR K DIFGFILE,DIFGSAVE,DA,DIC,DIFGTYPE,DIFGM,DIFGNDC,DIFGNODL,DIFGADD,DIFGMO,DIFGLAGO,DIFGSKIP,DIFGDI,DIFGDICS,DIFGADD,DIFGINCR,DIFGNODL,DIFGTYPE,DIFG("SAVE")
- K DIFGDA,DIFGDIC,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGNODE,DIFGNUM,DIFGSECP,DIFGSTRT,DIFGSVN,DIFGSVVL,DIFGMGBL
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG 3520 printed Feb 19, 2025@00:13:47 Page 2
- DIFG ;SFISC/DG(OHPRD)-FILEGRAM INSTALLER ;10/9/95 05:50
- +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 ;
- +7 IF $DATA(DIFGREI)
- SET DIFGLO="^DIAR(1.13,"_DIFGREI_",21,"
- KILL DIFGLC
- +8 IF '$DATA(DIFGLO)
- SET DIFGER="1^0"
- QUIT
- +9 IF $EXTRACT(DIFGLO,$LENGTH(DIFGLO))=","!($EXTRACT(DIFGLO,$LENGTH(DIFGLO))="(")
- +10 IF '$TEST
- SET DIFGER="1.25^0"
- KILL DIFGLO,DIFGREI
- QUIT
- +11 SET DIFGCHKG=$SELECT($EXTRACT(DIFGLO,$LENGTH(DIFGLO))=",":$EXTRACT(DIFGLO,1,$LENGTH(DIFGLO)-1)_")",1:$PIECE(DIFGLO,"("))
- +12 IF '$DATA(@(DIFGCHKG))
- SET DIFGER="1.5^0"
- KILL DIFGCHKG,DIFGLO,DIFGREI
- QUIT
- +13 DO INIT
- DO START
- DO KILLVAR
- DO EOJ^DIFG5
- +14 QUIT
- +15 ;
- INIT SET U="^"
- +1 KILL ^UTILITY("DIFG",$JOB),^UTILITY("DIFGFG",$JOB),^UTILITY("DIFGX",$JOB),^UTILITY("DIFG@",$JOB)
- +2 DO DT^DICRW
- +3 SET DIFGEXC="F DIFGL=1:1 Q:$E(DIFGDIX,DIFGL)'="" """
- +4 SET DIFGLINE="S DIFGY=$O("_DIFGLO_"DIFGY)) Q:DIFGY'>0 S DIFGDIX=^(DIFGY,0) X DIFGEXC S DIFGDIX=$E(DIFGDIX,DIFGL,255)"
- +5 QUIT
- +6 ;
- START SET (DIFG,DIFGER,DIFGMULT,DIFGEND,DIFGO,DIFGCT,DIFGADD,DIFGTYPE,DIFGINCR,DIFGNDC)=0
- SET DIFGY=$SELECT('$DATA(DIFGLC):.9999,1:DIFGLC-.0001)
- SET DIFGNODL=1
- DO FILEGRAM
- DO KILLVAR
- +1 if 'DIFGER
- DO ^DIFG6
- +2 QUIT
- +3 ;
- FILEGRAM XECUTE DIFGLINE
- +1 IF $PIECE(DIFGDIX,"^")'="$DAT"
- SET DIFGER=2_U_DIFGY
- DO ERROR
- GOTO X1
- +2 SET DIFG("PARAM")=$PIECE(DIFGDIX,U,4)
- +3 XECUTE DIFGLINE
- A IF $PIECE(DIFGDIX,":")="ENVIRONMENT"
- SET @($PIECE($PIECE(DIFGDIX,":",2),"=")_"="_$PIECE(DIFGDIX,"=",2))
- XECUTE DIFGLINE
- GOTO A
- +1 DO BASEFILE^DIFG0B
- if DIFGER
- GOTO X1
- +2 DO FILE
- X1 QUIT
- +1 ;
- FILE FOR DIFGL=0:0
- XECUTE DIFGLINE
- DO EVAL
- IF DIFGTYPE="TERM"!DIFGER
- SET DIFGTYPE=""
- QUIT
- +1 QUIT
- +2 ;
- EVAL DO GETTYPE
- +1 IF DIFGER
- GOTO X3
- +2 IF DIFGTYPE="TERM"
- GOTO X3
- +3 IF DIFGTYPE="MV FIELD"
- DO ^DIFG2
- GOTO X3
- +4 IF DIFGTYPE="SV FIELD"
- DO ^DIFG1
- GOTO X3
- +5 IF DIFGTYPE="WP FIELD"
- DO ^DIFG1
- GOTO X3
- +6 IF DIFGTYPE="SWITCH"
- DO SWITCH^DIFG0A
- GOTO X3
- +7 ;computed field, do not process
- IF DIFGTYPE="SKIP"
- X3 QUIT
- +1 ;
- GETTYPE IF DIFGDIX="^"!(DIFGDIX=":")!(DIFGDIX="$END DAT")
- SET DIFGTYPE="TERM"
- GOTO X4
- +1 IF $PIECE(DIFGDIX,U)="$DAT"!($PIECE(DIFGDIX,":")="$DAT")
- SET DIFGER=3_U_DIFGY
- SET DIFGEND=1
- SET DIFGTYPE="TERM"
- DO ERROR
- GOTO X4
- +2 IF $PIECE(DIFGDIX,U,2)[":"
- SET DIFGSTRT=$FIND(DIFGDIX,"^")
- SET DIFGFIND=$EXTRACT(DIFGDIX,DIFGSTRT,245)
- IF $EXTRACT(DIFGFIND,$FIND(DIFGFIND,":"))="^"
- SET DIFGTYPE="SWITCH"
- GOTO X4
- +3 DO EVALFLD
- X4 QUIT
- +1 ;
- EVALFLD IF DIFG("PARAM")["N"
- SET DIFGNUM=+$PIECE(DIFGDIX,U,2)
- +1 IF '$TEST
- SET DIFGNUM=$ORDER(^DD(DIC,"B",$PIECE(DIFGDIX,U),""))
- +2 IF '$DATA(^DD(DIC,DIFGNUM))
- SET DIFGER=4_U_DIFGY
- DO ERROR
- GOTO X5
- +3 IF $PIECE(^DD(DIC,DIFGNUM,0),U,2)["C"
- SET DIFGTYPE="SKIP"
- GOTO X5
- +4 IF +$PIECE(^DD(DIC,DIFGNUM,0),U,2)
- SET DIFGMLND=^DD(DIC,DIFGNUM,0)
- SET DIFGFLDN=DIFGNUM
- SET DIFGNUM=+$PIECE(DIFGMLND,U,2)
- SET DIFGTYPE=$SELECT($PIECE(^DD(DIFGNUM,.01,0),U,2)'["W":"MV FIELD",1:"WP FIELD")
- +5 IF '$TEST
- SET DIFGTYPE="SV FIELD"
- X5 QUIT
- +1 ;
- ERROR NEW DA,DIC,DIE,X,Y,DO
- +1 SET X=$PIECE(DIFGER,U,2)
- SET DIC("DR")=".02////"_$PIECE(DIFGER,U)
- SET DIC="^DIAR(1.13,"
- SET DIC(0)="FL"
- DO FILE^DICN
- SET DIFGLOG=$SELECT(Y>0:+Y,1:-1)
- if DIFGLOG=-1
- GOTO X6
- +2 SET B=0
- FOR A=$SELECT($DATA(DIFGLC):DIFGLC-.0001,1:0):0
- SET A=$ORDER(@(DIFGLO_"A)"))
- if 'A
- QUIT
- SET B=B+1
- SET ^DIAR(1.13,+Y,21,B,0)=$SELECT('$DATA(^UTILITY("DIFGFG",$JOB,A)):@(DIFGLO_"A,0)"),1:^UTILITY("DIFGFG",$JOB,A))
- if A=$PIECE(DIFGER,U,2)
- SET $PIECE(DIFGER,U,2)=B
- if ^(0)["$END DAT"
- QUIT
- +3 SET ^DIAR(1.13,+Y,21,0)="^^"_B_"^"_B_"^"_DT
- +4 SET DIE="^DIAR(1.13,"
- SET DA=DIFGLOG
- SET DR=".01///"_$PIECE(DIFGER,U,2)
- DO ^DIE
- KILL DIE,DA,DR
- +5 SET DIFGEROR=""
- X6 KILL A,B
- QUIT
- +1 ;
- KILLVAR KILL DIFGFILE,DIFGSAVE,DA,DIC,DIFGTYPE,DIFGM,DIFGNDC,DIFGNODL,DIFGADD,DIFGMO,DIFGLAGO,DIFGSKIP,DIFGDI,DIFGDICS,DIFGADD,DIFGINCR,DIFGNODL,DIFGTYPE,DIFG("SAVE")
- +1 KILL DIFGDA,DIFGDIC,DIFGFIND,DIFGFIRP,DIFGFLDN,DIFGHAT,DIFGNODE,DIFGNUM,DIFGSECP,DIFGSTRT,DIFGSVN,DIFGSVVL,DIFGMGBL
- +2 QUIT