DIFG6 ;SFISC/DG(OHPRD)-UPDATE FILES ;2/3/93 12:23 PM
;;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.
;
START ;
S DIFGORDR=0
F DIFGL=0:0 S DIFGORDR=$O(^UTILITY("DIFG",$J,DIFGORDR)) Q:DIFGORDR=""!(DIFGER) D SETVAR D:'$D(DIFGNODL) PROCESS K DIFGNODL
D EOJ
Q
;
SETVAR ;SET UP VARIABLES FOR DI* CALLS FOR A GIVEN ENTRY IN ^UTILITY("DIFG",$J,...)
S DIFGFILE=$O(^UTILITY("DIFG",$J,DIFGORDR,0))
S DIFGMODE=$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U)
I DIFGMODE="D",^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=-1 S DIFGNODL="" G X3
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"X")) S:^("X")["^UTILITY" ^("X")="~"_$E(^("X"),2,$L(^("X"))) S X=$S($P(^("X"),U,2)'="N"!(+^("X")):$P(^("X"),U),1:@($TR($P(^("X"),U),"~","^")))
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA(1)")) F DIFGI=1:1 Q:'$D(^("DA("_DIFGI_")")) S @("DA("_DIFGI_")="_^("DA("_DIFGI_")"))
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""P"")")) S DIC("P")=^("DIC(""P"")") ;Exists if a multiple and calling DIC to add
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")")) S DIC("DR")=^("DIC(""DR"")")
;I $D(DIC("DR")) S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")",DIFGZRO)) Q:'DIFGZRO S DIC("DR"
X3 Q
;
PROCESS ;DETERMINE WHICH DI* ROUTINE(S) TO CALL FOR A GIVEN ENTRY
I DIFGMODE="A" S DIC=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL") D CALLDIC^DIFG7 S:'DIFGER DIFGAVAL=+Y D:'DIFGER ADDCONT G X1
D BUILDDR
S DIE=^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"GL"),@("DA="_^("DA")) I $D(DR),DR]"" D CALLDIE^DIFG7 I $D(Y) S DIFGER=14_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG G X1
I DIFGMODE="D",'DIFGER S DIK=DIE D CALLDIK^DIFG7
I 'DIFGER S $P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"),"^",2)="I"
X1 K DIC,DIE,DIK,DA,DR,DIFGAVAL
Q
;
ADDCONT ;CONTINUATION OF MODE="A" PROCESSING UPON RETURN FROM ^DIC
S DA=DIFGAVAL,DIE=DIC
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"WP")) D WP^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=17_"^"_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_"^I" D ERROR^DIFG G X1
D BUILDDR
I $D(DR),DR]"" S DA=DIFGAVAL D CALLDIE^DIFG7 I $D(Y) S DIK=DIE,@(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))="" D CALLDIK^DIFG7 S DIFGER=15_U_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2) D ERROR^DIFG
I 'DIFGER S @(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA"))=DIFGAVAL,^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DA")=DIFGAVAL_"^I" D RESET
Q
;
BUILDDR ;SET DR (BUILD DR ARRAY IF APPROPRIATE)
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR")) S DR=^("DR")
I $D(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR"))=11 S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DR",DIFGZRO)) Q:'DIFGZRO S DR(1,DIFGFILE,DIFGZRO)=^(DIFGZRO)
Q
;
RESET ;RESETS MODE INDICATOR IN FILEGRAM FROM "A" TO "M"
I DIFGORDR'<1 S DIFGTMP=DIFGLO_$P(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"MODE"),U,2)_",0)",DIFGVL0=@DIFGTMP,DIFGVL1=$P(DIFGVL0,"="),DIFGVL2=$P(DIFGVL0,"=",2,3),$P(DIFGVL1,U,3)="M"
E G X2
S DIFGTMP="^UTILITY(""DIFGFG"",$J,$P(^UTILITY(""DIFG"",$J,DIFGORDR,DIFGFILE,""MODE""),U,2))"
S @(DIFGTMP_"=DIFGVL1_""=""_DIFGVL2")
;
X2 Q
;
EOJ K DIFGI,DIFGORDR,DIFGFILE,DIFGMODE,DIFGTMP,DIFGVL0,DIFGVL1,DIFGVL2,DIFGDRVL,DIFGDRPT,DIFGZRO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFG6 3724 printed Apr 09, 2024@21:48:43 Page 2
DIFG6 ;SFISC/DG(OHPRD)-UPDATE FILES ;2/3/93 12:23 PM
+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 ;
START ;
+1 SET DIFGORDR=0
+2 FOR DIFGL=0:0
SET DIFGORDR=$ORDER(^UTILITY("DIFG",$JOB,DIFGORDR))
if DIFGORDR=""!(DIFGER)
QUIT
DO SETVAR
if '$DATA(DIFGNODL)
DO PROCESS
KILL DIFGNODL
+3 DO EOJ
+4 QUIT
+5 ;
SETVAR ;SET UP VARIABLES FOR DI* CALLS FOR A GIVEN ENTRY IN ^UTILITY("DIFG",$J,...)
+1 SET DIFGFILE=$ORDER(^UTILITY("DIFG",$JOB,DIFGORDR,0))
+2 SET DIFGMODE=$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U)
+3 IF DIFGMODE="D"
IF ^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA")=-1
SET DIFGNODL=""
GOTO X3
+4 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"X"))
if ^("X")["^UTILITY"
SET ^("X")="~"_$EXTRACT(^("X"),2,$LENGTH(^("X")))
SET X=$SELECT($PIECE(^("X"),U,2)'="N"!(+^("X")):$PIECE(^("X"),U),1:@($TRANSLATE($PIECE(^("X"),U),"~","^")))
+5 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA(1)"))
FOR DIFGI=1:1
if '$DATA(^("DA("_DIFGI_")"))
QUIT
SET @("DA("_DIFGI_")="_^("DA("_DIFGI_")"))
+6 ;Exists if a multiple and calling DIC to add
IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DIC(""P"")"))
SET DIC("P")=^("DIC(""P"")")
+7 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DIC(""DR"")"))
SET DIC("DR")=^("DIC(""DR"")")
+8 ;I $D(DIC("DR")) S DIFGZRO=0 F DIFGL=0:0 S DIFGZRO=$O(^UTILITY("DIFG",$J,DIFGORDR,DIFGFILE,"DIC(""DR"")",DIFGZRO)) Q:'DIFGZRO S DIC("DR"
X3 QUIT
+1 ;
PROCESS ;DETERMINE WHICH DI* ROUTINE(S) TO CALL FOR A GIVEN ENTRY
+1 IF DIFGMODE="A"
SET DIC=^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"GL")
DO CALLDIC^DIFG7
if 'DIFGER
SET DIFGAVAL=+Y
if 'DIFGER
DO ADDCONT
GOTO X1
+2 DO BUILDDR
+3 SET DIE=^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"GL")
SET @("DA="_^("DA"))
IF $DATA(DR)
IF DR]""
DO CALLDIE^DIFG7
IF $DATA(Y)
SET DIFGER=14_U_$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U,2)
DO ERROR^DIFG
GOTO X1
+4 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"WP"))
DO WP^DIFG7
IF $DATA(Y)
SET DIFGER=17_"^"_$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U,2)
DO ERROR^DIFG
GOTO X1
+5 IF DIFGMODE="D"
IF 'DIFGER
SET DIK=DIE
DO CALLDIK^DIFG7
+6 IF 'DIFGER
SET $PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA"),"^",2)="I"
X1 KILL DIC,DIE,DIK,DA,DR,DIFGAVAL
+1 QUIT
+2 ;
ADDCONT ;CONTINUATION OF MODE="A" PROCESSING UPON RETURN FROM ^DIC
+1 SET DA=DIFGAVAL
SET DIE=DIC
+2 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"WP"))
DO WP^DIFG7
IF $DATA(Y)
SET DIK=DIE
SET @(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA"))=""
DO CALLDIK^DIFG7
SET DIFGER=17_"^"_$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U,2)_"^I"
DO ERROR^DIFG
GOTO X1
+3 DO BUILDDR
+4 IF $DATA(DR)
IF DR]""
SET DA=DIFGAVAL
DO CALLDIE^DIFG7
IF $DATA(Y)
SET DIK=DIE
SET @(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA"))=""
DO CALLDIK^DIFG7
SET DIFGER=15_U_$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U,2)
DO ERROR^DIFG
+5 IF 'DIFGER
SET @(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA"))=DIFGAVAL
SET ^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DA")=DIFGAVAL_"^I"
DO RESET
+6 QUIT
+7 ;
BUILDDR ;SET DR (BUILD DR ARRAY IF APPROPRIATE)
+1 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DR"))
SET DR=^("DR")
+2 IF $DATA(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DR"))=11
SET DIFGZRO=0
FOR DIFGL=0:0
SET DIFGZRO=$ORDER(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"DR",DIFGZRO))
if 'DIFGZRO
QUIT
SET DR(1,DIFGFILE,DIFGZRO)=^(DIFGZRO)
+3 QUIT
+4 ;
RESET ;RESETS MODE INDICATOR IN FILEGRAM FROM "A" TO "M"
+1 IF DIFGORDR'<1
SET DIFGTMP=DIFGLO_$PIECE(^UTILITY("DIFG",$JOB,DIFGORDR,DIFGFILE,"MODE"),U,2)_",0)"
SET DIFGVL0=@DIFGTMP
SET DIFGVL1=$PIECE(DIFGVL0,"=")
SET DIFGVL2=$PIECE(DIFGVL0,"=",2,3)
SET $PIECE(DIFGVL1,U,3)="M"
+2 IF '$TEST
GOTO X2
+3 SET DIFGTMP="^UTILITY(""DIFGFG"",$J,$P(^UTILITY(""DIFG"",$J,DIFGORDR,DIFGFILE,""MODE""),U,2))"
+4 SET @(DIFGTMP_"=DIFGVL1_""=""_DIFGVL2")
+5 ;
X2 QUIT
+1 ;
EOJ KILL DIFGI,DIFGORDR,DIFGFILE,DIFGMODE,DIFGTMP,DIFGVL0,DIFGVL1,DIFGVL2,DIFGDRVL,DIFGDRPT,DIFGZRO
+1 QUIT
