- PSJVINI3 ;BIR/-APR-1994;
- ;;4.5; Inpatient Medications ;;7 Oct 94
- ;
- ;
- 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^PSJVINI4
- 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
- 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))) W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
- 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
- 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
- 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
- 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
- PSJVINI3 ;BIR/-APR-1994;
- +1 ;;4.5; Inpatient Medications ;;7 Oct 94
- +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^PSJVINI4
- 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 SET DIC("S")="I $P(^(0),U,4)=DIFL"
- FOR N="DIPT","DIBT","DIE"
- SET DIC=U_N_"("
- DO ADD
- +5 KILL DIC("S")
- SET N="DIST(.404,"
- SET DIC=U_N
- SET DLAYGO=.404
- DO ADD
- +6 SET DIC("S")="I $P(^(0),U,8)=DIFL"
- SET N="DIST(.403,"
- SET DIC=U_N
- SET DLAYGO=.403
- DO ADD
- +7 KILL ^UTILITY(U,$JOB),DIC,DLAYGO
- FOR DIFR="DIE","DIPT"
- DO DIEZ
- +8 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)))
- WRITE !,"**WARNING--"_$SELECT(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$PIECE(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
- +4 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)
- +5 IF N="DIST(.403,"
- DO BLK
- +6 SET %X="^UTILITY(U,$J,N,R,"
- SET %Y=DIC_"+Y,"
- SET DA=+Y
- SET DIK=DIC
- DO %XY^%RCR
- +7 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
- +8 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
- +1 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
- +2 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
- +3 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")
- +4 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
