DIFROM11 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;APR 13, 1995@14:31
;;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.
;
S %Y="^UTILITY(U,$J,D,Y,",E=0
F D="DIE","DIPT","DIBT" S %X=U_D_"(Y,",Y=0 F S @("Y=$O(^"_D_"(Y))") Q:'Y I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,4) I F,$P(DSV,U,8)<3,$D(F(F))!$D(Q(D,Y)) D 1
S D="DIST(.403,",%X=U_D_"Y,",Y=0 F S Y=$O(^DIST(.403,Y)) Q:'Y I $D(^(Y,0))#2 S DSV=^(0),F=$P(DSV,U,8) I F,$D(F(F))!$D(Q("DIST",Y)) D 1
S X="" F D=0:0 S X=$O(^UTILITY(U,$J,X)) Q:X="" S %X="^UTILITY(U,$J,"_""""_X_"""," D %XY^DIFROM1
K ^UTILITY(U,$J) D FILE^DIFROM3:DL K ^UTILITY($J) G:'$D(DRN) EQ
D DIFROM2 G Q
1 ;
I 'DIT F %=0:0 S %=$O(^DIC(9.4,DPK,"EX",%)) Q:%'>0 I $P($P(DSV,U),$P(^(%,0),U))="" G QQ
I D["DIST" I DIT!($P($P(DSV,U),DTL)="")!$D(Q("DIST",Y)) S Q("DIST")=0 D %XY^%RCR S $P(DSV,U,4)="",$P(DSV,U,6)="" S:'DSEC $P(DSV,U,2,3)=U S ^UTILITY(U,$J,D,Y,0)=DSV D BLK G QQ
I DIT!($P($P(DSV,U),DTL)="")!$D(Q(D,Y)) S Q(D)=0 D %XY^%RCR K ^UTILITY(U,$J,D,Y,"RD"),^("AB") K:'$D(DTL(F))&(D["DIBT") ^(1) S:'DSEC ^(0)=$P(DSV,U,1,2)_U_U_F_U_U_U_U_$P(DSV,U,8,9) W "."
QQ Q
BLK N D,%X S D="DIST(.404,",%X=U_D_"Y,"
F I=0:0 S I=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I)) Q:'I I $D(^(I,0)) S %=+$P(^(0),U,2) S:$D(^DIST(.404,%,0)) $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,0),U,2)=$P(^(0),U) S K=Y,Y=% D:$D(^DIST(.404,%,0)) %XY^%RCR S Y=K D B2
Q
B2 F J=0:0 S J=$O(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J)) Q:'J I $D(^(J,0)) S %=+^(0) I $D(^DIST(.404,%,0)) S $P(^UTILITY(U,$J,"DIST(.403,",Y,40,I,40,J,0),U)=$P(^(0),U),K=Y,Y=% D %XY^%RCR S Y=K
Q
;
DIFROM2 ;
S DIFROM=5,Y=DRN-1,S=""
S DH=" ; LOADS AND INDEXES DD'S",^UTILITY($J,.3,0)=" K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U=""^"",DSEC=1"
S X="",DD="A" F E=1:1 S DD=$O(Q(DD)) Q:DD="" S X=X_","""_$E(DD,1,3)_""""
S DL=0,^UTILITY($J,1.4,0)=" S NO=$P(""I 0^I $D(@X)#2,X[U"",U,%) I %<1 K DIFQ Q"
S DIRS(1)=" I %<1 K DIFQ Q"
S:E>1 ^UTILITY($J,2,0)=" F X="_$E(X,2,99)_" D W Q:'$D(DIFQ)"
G ^DIFROM2
;
EQ W $C(7),!!,"PACKAGE TOO LARGE! DIFROM CAN NOT BUILD ANY MORE INIT ROUTINES.",!!
Q K ^UTILITY($J),^("^",$J),^UTILITY("DIF",$J),DIFROM,DR,DD,DLAYGO,DIRS,DIMA,DWLW,DREF,D1
K DI,DISYS,DIX,DIY,DO,DZ,DIK,DIDUZ,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW
K %,%1,%2,%A,%B,%C,%DT,%V,%X,%Y,%Z,DDH,DG,D0,DA,DIFRM,DL,D,E,DIC,DIE,DN,DPK,DQ
K DIFC,DRN,DIRUT,DIROUT,DTOUT,DUOUT,DIR,DIFQR,DNAME,DSEC,DTL
K A,C,I,J,K,F,L,N,Q,R,S,X,Y,Z,DSV,DIDIU,DIFKEP,DIFR,DIFR1,DIFR2,DIT,DH,DILN2,DIFL,VERSION
K DIFRDIFI,DIFRF,DIFRIR,DIFRRMAX,DIFRRN,DIFRRTN,DIFRRXT,DIFRS,DIFRTX
K DIOVRD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROM11 2859 printed Dec 13, 2024@02:48 Page 2
DIFROM11 ;SFISC/XAK-CREATES RTN ENDING IN INIT1 ;APR 13, 1995@14:31
+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 SET %Y="^UTILITY(U,$J,D,Y,"
SET E=0
+8 FOR D="DIE","DIPT","DIBT"
SET %X=U_D_"(Y,"
SET Y=0
FOR
SET @("Y=$O(^"_D_"(Y))")
if 'Y
QUIT
IF $DATA(^(Y,0))#2
SET DSV=^(0)
SET F=$PIECE(DSV,U,4)
IF F
IF $PIECE(DSV,U,8)<3
IF $DATA(F(F))!$DATA(Q(D,Y))
DO 1
+9 SET D="DIST(.403,"
SET %X=U_D_"Y,"
SET Y=0
FOR
SET Y=$ORDER(^DIST(.403,Y))
if 'Y
QUIT
IF $DATA(^(Y,0))#2
SET DSV=^(0)
SET F=$PIECE(DSV,U,8)
IF F
IF $DATA(F(F))!$DATA(Q("DIST",Y))
DO 1
+10 SET X=""
FOR D=0:0
SET X=$ORDER(^UTILITY(U,$JOB,X))
if X=""
QUIT
SET %X="^UTILITY(U,$J,"_""""_X_""","
DO %XY^DIFROM1
+11 KILL ^UTILITY(U,$JOB)
if DL
DO FILE^DIFROM3
KILL ^UTILITY($JOB)
if '$DATA(DRN)
GOTO EQ
+12 DO DIFROM2
GOTO Q
1 ;
+1 IF 'DIT
FOR %=0:0
SET %=$ORDER(^DIC(9.4,DPK,"EX",%))
if %'>0
QUIT
IF $PIECE($PIECE(DSV,U),$PIECE(^(%,0),U))=""
GOTO QQ
+2 IF D["DIST"
IF DIT!($PIECE($PIECE(DSV,U),DTL)="")!$DATA(Q("DIST",Y))
SET Q("DIST")=0
DO %XY^%RCR
SET $PIECE(DSV,U,4)=""
SET $PIECE(DSV,U,6)=""
if 'DSEC
SET $PIECE(DSV,U,2,3)=U
SET ^UTILITY(U,$JOB,D,Y,0)=DSV
DO BLK
GOTO QQ
+3 IF DIT!($PIECE($PIECE(DSV,U),DTL)="")!$DATA(Q(D,Y))
SET Q(D)=0
DO %XY^%RCR
KILL ^UTILITY(U,$JOB,D,Y,"RD"),^("AB")
if '$DATA(DTL(F))&(D["DIBT")
KILL ^(1)
if 'DSEC
SET ^(0)=$PIECE(DSV,U,1,2)_U_U_F_U_U_U_U_$PIECE(DSV,U,8,9)
WRITE "."
QQ QUIT
BLK NEW D,%X
SET D="DIST(.404,"
SET %X=U_D_"Y,"
+1 FOR I=0:0
SET I=$ORDER(^UTILITY(U,$JOB,"DIST(.403,",Y,40,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET %=+$PIECE(^(0),U,2)
if $DATA(^DIST(.404,%,0))
SET $PIECE(^UTILITY(U,$JOB,"DIST(.403,",Y,40,I,0),U,2)=$PIECE(^(0),U)
SET K=Y
SET Y=%
if $DATA(^DIST(.404,%,0))
DO %XY^%RCR
SET Y=K
DO B2
+2 QUIT
B2 FOR J=0:0
SET J=$ORDER(^UTILITY(U,$JOB,"DIST(.403,",Y,40,I,40,J))
if 'J
QUIT
IF $DATA(^(J,0))
SET %=+^(0)
IF $DATA(^DIST(.404,%,0))
SET $PIECE(^UTILITY(U,$JOB,"DIST(.403,",Y,40,I,40,J,0),U)=$PIECE(^(0),U)
SET K=Y
SET Y=%
DO %XY^%RCR
SET Y=K
+1 QUIT
+2 ;
DIFROM2 ;
+1 SET DIFROM=5
SET Y=DRN-1
SET S=""
+2 SET DH=" ; LOADS AND INDEXES DD'S"
SET ^UTILITY($JOB,.3,0)=" K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U=""^"",DSEC=1"
+3 SET X=""
SET DD="A"
FOR E=1:1
SET DD=$ORDER(Q(DD))
if DD=""
QUIT
SET X=X_","""_$EXTRACT(DD,1,3)_""""
+4 SET DL=0
SET ^UTILITY($JOB,1.4,0)=" S NO=$P(""I 0^I $D(@X)#2,X[U"",U,%) I %<1 K DIFQ Q"
+5 SET DIRS(1)=" I %<1 K DIFQ Q"
+6 if E>1
SET ^UTILITY($JOB,2,0)=" F X="_$EXTRACT(X,2,99)_" D W Q:'$D(DIFQ)"
+7 GOTO ^DIFROM2
+8 ;
EQ WRITE $CHAR(7),!!,"PACKAGE TOO LARGE! DIFROM CAN NOT BUILD ANY MORE INIT ROUTINES.",!!
Q KILL ^UTILITY($JOB),^("^",$JOB),^UTILITY("DIF",$JOB),DIFROM,DR,DD,DLAYGO,DIRS,DIMA,DWLW,DREF,D1
+1 KILL DI,DISYS,DIX,DIY,DO,DZ,DIK,DIDUZ,DIFQ,DDF,DDT,NO,DIF,DIG,DIH,DIU,DIV,DIW
+2 KILL %,%1,%2,%A,%B,%C,%DT,%V,%X,%Y,%Z,DDH,DG,D0,DA,DIFRM,DL,D,E,DIC,DIE,DN,DPK,DQ
+3 KILL DIFC,DRN,DIRUT,DIROUT,DTOUT,DUOUT,DIR,DIFQR,DNAME,DSEC,DTL
+4 KILL A,C,I,J,K,F,L,N,Q,R,S,X,Y,Z,DSV,DIDIU,DIFKEP,DIFR,DIFR1,DIFR2,DIT,DH,DILN2,DIFL,VERSION
+5 KILL DIFRDIFI,DIFRF,DIFRIR,DIFRRMAX,DIFRRN,DIFRRTN,DIFRRXT,DIFRS,DIFRTX
+6 KILL DIOVRD
+7 QUIT
