DIFROM42 ;SFISC/XAK-CREATES 'INIT4' ;10/9/95 05:59
;;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 DNAME=E_4,DL=0,(DH,Q)=" ;"
K ^UTILITY($J) F DD=1:1 S X=$T(TXT+DD) Q:X="" S ^UTILITY($J,DD,0)=$E(X,4,999)
S DIFROM=2 D ZI^DIFROM3 G ^DIFROM5
TXT ;
;;EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
;; S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
;; S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
;; D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
;; I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
;; D OR
;; S DA(1)=1 D IX1^DIK
;; Q
;;OR S (N,I)=0,X=""
;; F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
;; S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
;; F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
;; S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
;; Q
;;OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
;; S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
;; Q
;;ADDP N I,J,N,R,DA,DLAYGO,DO S %=""
;; S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROM42 1777 printed Oct 16, 2024@18:48:39 Page 2
DIFROM42 ;SFISC/XAK-CREATES 'INIT4' ;10/9/95 05:59
+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 DNAME=E_4
SET DL=0
SET (DH,Q)=" ;"
+8 KILL ^UTILITY($JOB)
FOR DD=1:1
SET X=$TEXT(TXT+DD)
if X=""
QUIT
SET ^UTILITY($JOB,DD,0)=$EXTRACT(X,4,999)
+9 SET DIFROM=2
DO ZI^DIFROM3
GOTO ^DIFROM5
TXT ;
+1 ;;EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
+2 ;; S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
+3 ;; S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
+4 ;; D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
+5 ;; I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
+6 ;; D OR
+7 ;; S DA(1)=1 D IX1^DIK
+8 ;; Q
+9 ;;OR S (N,I)=0,X=""
+10 ;; F S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
+11 ;; S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
+12 ;; F S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
+13 ;; S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
+14 ;; Q
+15 ;;OR1 N X F S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
+16 ;; S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
+17 ;; Q
+18 ;;ADDP N I,J,N,R,DA,DLAYGO,DO S %=""
+19 ;; S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1 S %=+Y Q
