IBDEI3E0 ; ; 05-NOV-2019
;;3.0;IB ENCOUNTER FORM IMP/EXP;;NOV 05, 2019
;
;
I N="DIST(.403," D
.N DIFRVAL S DIFRVAL=$$VAL^DIFROMSS(.403,DA)
.I DIFRVAL W !,"Compiling form: ",$P(^DIST(.403,DA,0),U) D EN^DDSZ(DA) Q
.W !,"ERROR: Form: ",$P(^DIST(.403,DA,0),U)," cannot be compiled"
.Q
Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0 D
.N X S X=0
.F S X=$O(^UTILITY(U,$J,N,R,40,J,40,L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,"BLK",%,X)=^(X)
.Q
S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0="" K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1 D
.N X S X=0
.F S X=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L,X)) Q:X="" S ^UTILITY(U,$J,N,R,40,J,40,L,X)=^(X)
.Q
S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
Q
KAD(D0) N D1,X
S X=0 F S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0 S D1=0 F S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0 K ^DIC(19,"AD",X,D0,D1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDEI3E0 1315 printed Apr 09, 2024@21:07:29 Page 2
IBDEI3E0 ; ; 05-NOV-2019
+1 ;;3.0;IB ENCOUNTER FORM IMP/EXP;;NOV 05, 2019
+2 ;
+3 ;
+4 IF N="DIST(.403,"
Begin DoDot:1
+5 NEW DIFRVAL
SET DIFRVAL=$$VAL^DIFROMSS(.403,DA)
+6 IF DIFRVAL
WRITE !,"Compiling form: ",$PIECE(^DIST(.403,DA,0),U)
DO EN^DDSZ(DA)
QUIT
+7 WRITE !,"ERROR: Form: ",$PIECE(^DIST(.403,DA,0),U)," cannot be compiled"
+8 QUIT
End DoDot:1
+9 QUIT
BLK FOR J=0:0
SET J=$ORDER(^UTILITY(U,$JOB,N,R,40,J))
if 'J
QUIT
IF $DATA(^(J,0))
SET %=$PIECE(^(0),U,2)
if %]""
SET %=$ORDER(^DIST(.404,"B",%,0))
if %
SET $PIECE(^UTILITY(U,$JOB,N,R,40,J,0),U,2)=%
DO B1
+1 KILL A0,A1,A2,J,L
QUIT
B1 FOR L=0:0
SET L=$ORDER(^UTILITY(U,$JOB,N,R,40,J,40,L))
if 'L
QUIT
SET A0=$GET(^(L,0))
SET %=$PIECE(A0,U)
IF %]""
SET %=$ORDER(^DIST(.404,"B",%,0))
IF %
SET $PIECE(A0,U)=%
SET ^UTILITY(U,$JOB,N,R,40,J,"BLK",%,0)=A0
Begin DoDot:1
+1 NEW X
SET X=0
+2 FOR
SET X=$ORDER(^UTILITY(U,$JOB,N,R,40,J,40,L,X))
if X=""
QUIT
SET ^UTILITY(U,$JOB,N,R,40,J,"BLK",%,X)=^(X)
+3 QUIT
End DoDot:1
+4 SET A0=$GET(^UTILITY(U,$JOB,N,R,40,J,40,0))
if A0=""
QUIT
KILL ^UTILITY(U,$JOB,N,R,40,J,40)
SET (A1,A2)=0
+5 FOR L=0:0
SET L=$ORDER(^UTILITY(U,$JOB,N,R,40,J,"BLK",L))
if 'L
QUIT
SET ^UTILITY(U,$JOB,N,R,40,J,40,L,0)=^(L,0)
SET A1=L
SET A2=A2+1
Begin DoDot:1
+6 NEW X
SET X=0
+7 FOR
SET X=$ORDER(^UTILITY(U,$JOB,N,R,40,J,"BLK",L,X))
if X=""
QUIT
SET ^UTILITY(U,$JOB,N,R,40,J,40,L,X)=^(X)
+8 QUIT
End DoDot:1
+9 SET $PIECE(A0,U,3,4)=A1_U_A2
SET ^UTILITY(U,$JOB,N,R,40,J,40,0)=A0
KILL ^UTILITY(U,$JOB,N,R,40,J,"BLK")
+10 QUIT
KAD(D0) NEW D1,X
+1 SET X=0
FOR
SET X=$ORDER(^DIC(19,D0,10,"B",X))
if X'>0
QUIT
SET D1=0
FOR
SET D1=$ORDER(^DIC(19,D0,10,"B",X,D1))
if D1'>0
QUIT
KILL ^DIC(19,"AD",X,D0,D1)
+2 QUIT
