IBDEINI3 ; ; 01-AUG-2022
;;3.0;IB ENCOUNTER FORM IMP/EXP;;AUG 01, 2022
;
;
K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X="" W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^IBDEINI4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
S DIC=.5,DLAYGO=0,N="FUN" D ADD
I $P($G(^DIC(8994,0)),U)="REMOTE PROCEDURE" S (DIC,DLAYGO)=8994,N="REM" D ADD
S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
E S DISYS=^DD("OS")
Q:'$D(^DD("OS",DISYS,"ZS"))
S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2 S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
G DZ1
;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'% S %(%)=$G(^(%,0))
K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'% S @(DIC_"+Y,2,%,0)")=%(%)
I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) D
.W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$S(N'["DIST":" template ",1:" ")_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
.Q
I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
I N="DIST(.403," D BLK
S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
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[HIBDEINI3 5024 printed Oct 16, 2024@18:51:15 Page 2
IBDEINI3 ; ; 01-AUG-2022
+1 ;;3.0;IB ENCOUNTER FORM IMP/EXP;;AUG 01, 2022
+2 ;
+3 ;
+4 KILL ^UTILITY("DIFROM",$JOB)
SET DIC(0)="LX"
SET (DIC,DLAYGO)=3.6
SET N="BUL"
if $DATA(^XMB(3.6,0))
DO ADD
+5 SET X=0
FOR R=0:0
SET X=$ORDER(^UTILITY("DIFROM",$JOB,N,X))
if X=""
QUIT
WRITE !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
+6 IF $DATA(^DIC(9.4,0))#2
IF ^(0)?1"PACK".E
SET N="PKG"
SET (DIC,DLAYGO)=9.4
DO ADD
+7 if '$DATA(DA)
GOTO NP
SET %=+$ORDER(^DIC(9.4,DA,22,"B",DIFROM,0))
IF $DATA(^DIC(9.4,DA,22,%,0))
SET $PIECE(^(0),U,3)=DT
+8 IF $DATA(^DIC(9.4,DA,0))#2
SET %=$PIECE(^(0),U,4)
IF %]""
SET %=$ORDER(^DIC(9.2,"B",%,0))
if %]""
SET $PIECE(^DIC(9.4,DA,0),U,4)=%
OR IF $DATA(^ORD(100.99))&$ORDER(^UTILITY(U,$JOB,"OR",""))
DO EN^IBDEINI4
NP KILL DIC,^UTILITY("DIFROM",$JOB)
SET DIC(0)="LX"
IF $DATA(^DIC(19,0))#2
IF ^(0)?1"OPTION".E
SET (DIC,DLAYGO)=19
SET N="OPT"
DO ADD
DO OP
+1 IF $DATA(^DIC(19.1,0))#2
IF ($PIECE(^(0),U)?1"SECUR".E)!($PIECE(^(0),U)="KEY")
SET (DIC,DLAYGO)=19.1
SET N="KEY"
DO ADD
KILL ^UTILITY("DIFROM",$JOB)
+2 IF $DATA(^DIC(9.8,0))#2
IF ^(0)?1"ROUTINE^".E
SET (DIC,DLAYGO)=9.8
SET N="RTN"
DO ADD
+3 SET DIC=.5
SET DLAYGO=0
SET N="FUN"
DO ADD
+4 IF $PIECE($GET(^DIC(8994,0)),U)="REMOTE PROCEDURE"
SET (DIC,DLAYGO)=8994
SET N="REM"
DO ADD
+5 SET DIC("S")="I $P(^(0),U,4)=DIFL"
FOR N="DIPT","DIBT","DIE"
SET DIC=U_N_"("
DO ADD
+6 KILL DIC("S")
SET N="DIST(.404,"
SET DIC=U_N
SET DLAYGO=.404
DO ADD
+7 SET DIC("S")="I $P(^(0),U,8)=DIFL"
SET N="DIST(.403,"
SET DIC=U_N
SET DLAYGO=.403
DO ADD
+8 KILL ^UTILITY(U,$JOB),DIC,DLAYGO
FOR DIFR="DIE","DIPT"
DO DIEZ
+9 KILL ^UTILITY("DIFROM",$JOB)
QUIT
DIEZ IF ^DD("VERSION")>17.4
IF '$DATA(DISYS)
DO OS^DII
+1 IF '$TEST
SET DISYS=^DD("OS")
+2 if '$DATA(^DD("OS",DISYS,"ZS"))
QUIT
+3 SET DIFR1=""
DZ1 SET DIFR1=$ORDER(^UTILITY("DIFROM",$JOB,DIFR,DIFR1))
if DIFR1=""
QUIT
+1 FOR DIFR2=0:0
SET DIFR2=$ORDER(^UTILITY("DIFROM",$JOB,DIFR,DIFR1,DIFR2))
if 'DIFR2
QUIT
SET Y=DIFR2
IF $DATA(@(U_DIFR_"(Y,""ROU"")"))
KILL ^("ROU")
IF $DATA(^("ROUOLD"))
SET X=^("ROUOLD")
SET DMAX=^DD("ROU")
if X]""
DO @("EN^DI"_$EXTRACT(DIFR,3)_"Z")
+2 GOTO DZ1
+3 ;
OP SET R=$ORDER(^UTILITY("DIFROM",$JOB,N,R))
IF R=""
KILL ^UTILITY("DIFROM",$JOB)
GOTO Q
+1 WRITE !,"'"_R_"' Option Filed"
SET DA=+^UTILITY("DIFROM",$JOB,N,R)
if $PIECE(^(R),U,2,3)="XUCORE^"!($PIECE(^(R),U,2,3)="XUCOMMAND^")
GOTO OP
+2 IF $DATA(^DIC(19,DA,220))
SET %=$PIECE(^(220),U)
if %]""
SET %=$ORDER(^XMB(3.6,"B",%,0))
SET $PIECE(^DIC(19,DA,220),U)=%
SET %=$PIECE(^(220),U,3)
if %]""
SET %=$ORDER(^XMB(3.8,"B",%,0))
SET $PIECE(^DIC(19,DA,220),U,3)=%
+3 SET %=$PIECE(^DIC(19,DA,0),U,12)
if %]""
SET %=$ORDER(^DIC(9.4,"B",%,0))
+4 SET $PIECE(^DIC(19,DA,0),U,12)=%
SET %=$PIECE(^(0),U,7)
SET (DZ,DIX)=0
+5 if $DATA(^DIC(19,DA,10,"B"))
DO KAD(DA)
if %]""
SET %=$ORDER(^DIC(9.2,"B",%,0))
SET $PIECE(^DIC(19,DA,0),U,7)=%
SET %=$PIECE(^(0),U,4)
SET %="MOQXL"[%
KILL ^(10,"B"),^("C")
+6 FOR X=0:0
SET X=$ORDER(^DIC(19,DA,10,X))
if 'X
QUIT
SET I=$SELECT($DATA(^(X,0)):^(0),1:0)
SET Y=$SELECT($DATA(^(U)):^(U),1:"")
KILL ^DIC(19,DA,10,X)
IF Y]""
IF %
SET D=$ORDER(^DIC(19,"B",Y,0))
IF D
SET ^DIC(19,DA,10,X,0)=D_U_$PIECE(I,U,2,9)
SET DZ=DZ+1
SET DIX=X
+7 if %
SET ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ
DO IX1^DIK
GOTO OP
+8 ;
ADD FOR R=0:0
SET R=$ORDER(^UTILITY(U,$JOB,N,R))
if R=""
QUIT
SET X=$PIECE(^(R,0),U)
SET DIFL=$SELECT(N="DIST(.403,":$PIECE(^(0),U,8),N="DIST(.404,":$PIECE(^(0),U,2),1:$PIECE(^(0),U,4))
WRITE "."
KILL DA
DO ^DIC
IF Y>0
IF '$DATA(DIFQ($EXTRACT(N,1,3)))!$PIECE(Y,U,3)
SET Y=Y_U
DO A
Q QUIT
A IF N="BUL"
KILL %
SET %(0)=$GET(@(DIC_"+Y,2,0)"))
FOR %=0:0
SET %=$ORDER(@(DIC_"+Y,2,%)"))
if '%
QUIT
SET %(%)=$GET(^(%,0))
+1 if N'="KEY"&(N'="OPT")
KILL @(DIC_"+Y)")
SET ^UTILITY("DIFROM",$JOB,N,X)=Y
if $EXTRACT(N,1,2)="DI"
SET ^(X,+Y)=""
if N="PKG"
SET DIFROM(0)=+Y
if $PIECE(Y,U,2,3)="XUCORE^"!($PIECE(Y,U,2,3)="XUCOMMAND^")
QUIT
+2 IF N="BUL"
IF %(0)]""
SET @(DIC_"+Y,2,0)")=%(0)
FOR %=0:0
SET %=$ORDER(%(%))
if '%
QUIT
SET @(DIC_"+Y,2,%,0)")=%(%)
+3 IF $EXTRACT(N,1,2)="DI"
IF ('DIFL)!('$DATA(^DD(+DIFL)))
Begin DoDot:1
+4 WRITE !,"**WARNING--"_$SELECT(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_$SELECT(N'["DIST":" template ",1:" ")_$PIECE(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" is not on your system!"
+5 QUIT
End DoDot:1
+6 IF N="OPT"
if $PIECE(^DIC(19,+Y,0),U,6)]""
SET DIOPT=$PIECE(^(0),U,6)
IF $ORDER(^UTILITY(U,$JOB,N,R,1,0))
KILL ^DIC(19,+Y,1)
+7 IF N="DIST(.403,"
DO BLK
+8 SET %X="^UTILITY(U,$J,N,R,"
SET %Y=DIC_"+Y,"
SET DA=+Y
SET DIK=DIC
DO %XY^%RCR
+9 if N'="OPT"
DO IX1^DIK
IF N="OPT"
IF $DATA(DIOPT)
if $PIECE(^DIC(19,DA,0),U,6)=""
SET $PIECE(^(0),U,6)=DIOPT
KILL DIOPT
+10 IF N="DIST(.403,"
Begin DoDot:1
+11 NEW DIFRVAL
SET DIFRVAL=$$VAL^DIFROMSS(.403,DA)
+12 IF DIFRVAL
WRITE !,"Compiling form: ",$PIECE(^DIST(.403,DA,0),U)
DO EN^DDSZ(DA)
QUIT
+13 WRITE !,"ERROR: Form: ",$PIECE(^DIST(.403,DA,0),U)," cannot be compiled"
+14 QUIT
End DoDot:1
+15 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
