- ACDONIT3 ;IHS/ADC/EDE/KML - NO DESCRIPTION PROVIDED;
- ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
- ;
- ;
- K ^UTILITY("ORVROM",$J) S DIC(0)="LX",ORNMCHK=1 I $D(^ORD(101,0))#2,^(0)?1"PROTOCOL".E S DIC="^ORD(101,",DLAYGO=101,N="PRO" D ADD,OP
- K ^UTILITY(U,$J),DIC,DLAYGO
- Q
- DIEZ I ^DD("VERSION")>17.4,'$D(DISYS),$D(^%ZOSF("OS"))#2 S DISYS=+$P(^("OS"),"^",2)
- E S DISYS=^DD("OS")
- Q:'$D(^DD("OS",DISYS,"ZS"))
- S N=$O(^UTILITY("ORVROM",$J,DIR,0)) Q:N="" S Y=+^(N) K ^(N)
- I $D(@("^"_DIR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIR,3)_"Z")
- G DIEZ
- ;
- OP S NM=$O(^UTILITY("ORVROM",$J,N,NM)) I NM="" K ^UTILITY("ORVROM",$J) G Q
- S R=$O(^UTILITY("ORVROM",$J,N,NM,0)) G:R="" OP
- W !,"'"_NM_"' Protocol Filed" S DA=+^UTILITY("ORVROM",$J,N,NM,R)
- S %=$P(^ORD(101,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
- S $P(^ORD(101,DA,0),U,12)=%,(ORDZ,ORDIX)=0
- S %=$S($D(^ORD(101,DA,5)):$P(^(5),"^"),1:"") I $L(%) S $P(^(5),"^")="",X=$P(%,";",2),%=$P(%,";") I $D(@("^"_X_"""B"","""_%_""")")) S %=$O(^(%,0)) S %=$S(%:%_";"_X,1:""),$P(^ORD(101,DA,5),"^")=%
- I $D(^ORD(101,DA,3,0)) S I=0 F S I=$O(^ORD(101,DA,3,I)) Q:I<1 S KEY=^(I,0) K ^(0) I $D(^DIC(19.1,"B",KEY)) S KEY=$O(^(KEY,0)) I KEY S ^ORD(101,DA,3,I,0)=KEY
- I $D(^ORD(101,DA,3)) S I=0 F S I=$O(^ORD(101,DA,3,I)) Q:I<1 S ORDZ=ORDZ+1,ORDIX=X
- I S $P(^ORD(101,DA,3,0),"^",3,4)=ORDIX_"^"_ORDZ
- I $D(^UTILITY("ORVROM",$J,N,NM,R,10)) S X=0 F S X=$O(^UTILITY("ORVROM",$J,N,NM,R,10,X)) Q:X<1 D A1
- S (ORDZ,ORDIX)=0 S X=0 F S X=$O(^ORD(101,DA,10,X)) Q:X<1 S ORDZ=ORDZ+1,ORDIX=X
- S:$D(^ORD(101,DA,10,0)) ^(0)="^101.01PA^"_ORDIX_U_ORDZ D IX1^DIK
- I $D(^UTILITY("ORVROM",$J,N,NM,R,"MEN")) S IMEN=0 F S IMEN=$O(^UTILITY("ORVROM",$J,N,NM,R,"MEN",IMEN)) Q:IMEN="" S OMEN=^(IMEN),MEN=IMEN D MEN
- K MEN,IMEN,OMEN
- G OP
- ;
- ADD S R=0 F S R=$O(^UTILITY(U,$J,N,R)) Q:R="" S X=$P(^(R,0),U),I=$P(^(0),U,4) D
- . I $L($T(DOT^ORVOM)) D DOT^ORVOM
- . I '$L($T(DOT^ORVOM)) W "."
- . I $O(^ORD(101,"B",X,0)) S Y=$O(^(0)),ORA=Y,Y=Y_U D A Q
- . D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ORA=Y,Y=Y_U D A
- Q K ORA,MEN,OMEN,ORNMCHK,ORDZ,ORDIX S (NM,R)=0 Q
- A S ^UTILITY("ORVROM",$J,N,X,R)=Y
- I $O(^UTILITY(U,$J,N,R,1,0))>0 K ^ORD(101,+Y,1)
- I $O(^UTILITY(U,$J,N,R,10,0))>0 S %X="^UTILITY(U,$J,N,R,10,",%Y="^UTILITY(""ORVROM"",$J,N,X,R,10," D %XY^%RCR K ^UTILITY(U,$J,N,R,10)
- I $D(^UTILITY(U,$J,N,R,"MEN")) S %X="^UTILITY(U,$J,N,R,""MEN"",",%Y="^UTILITY(""ORVROM"",$J,N,X,R,""MEN""," D %XY^%RCR K ^UTILITY(U,$J,N,R,"MEN")
- S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+ORA,",DA=+ORA,DIK=DIC D %XY^%RCR
- Q
- A1 S ORA=DA N DA,DIC,ORI S Y="",ORI=0,DIC="^ORD(101,"_+ORA_",10,",DIC(0)="L",DA(1)=+ORA S:'$D(^ORD(101,DA(1),10,0)) ^(0)="^101.01PA^^"
- F S ORI=$O(^UTILITY("ORVROM",$J,N,NM,R,10,ORI)) Q:ORI<1 S X0=^(ORI,0),X=$S($D(^(U)):^(U),1:"") I $L(X) D A2
- K DA,^UTILITY("ORVROM",$J,N,NM,R,10)
- Q
- A2 N X1 S DLAYGO=101 D ^DIC Q:'Y
- I $P(Y,"^",3) W !?2,X_" added as item to "_$P(^ORD(101,DA(1),0),"^")_"."
- S X0=^UTILITY("ORVROM",$J,N,NM,R,10,ORI,0)
- S %=$P(X0,"^",4) I $L(%) S %=$O(^ORD(101,"B",%,0)) S:% $P(X0,"^",4)=%
- S $P(^ORD(101,DA(1),10,+Y,0),"^",2,99)=$P(X0,"^",2,99)
- S X1=0 F S X1=$O(^UTILITY("ORVROM",$J,N,NM,R,10,ORI,X1)) Q:X1="" I X1'["^" S X0=^UTILITY("ORVROM",$J,N,NM,R,10,ORI,X1),^ORD(101,DA(1),10,+Y,X1)=X0
- Q
- MEN S MEN=$S($D(^ORD(101,"B",MEN)):$O(^(MEN,0)),1:"") I 'MEN K ^UTILITY("ORVROM",$J,N,NM,R,"MEN") Q
- S X=NM,X0=OMEN,DIC="^ORD(101,"_MEN_",10,",DIC(0)="L",DA(1)=MEN S:'$D(^ORD(101,DA(1),10,0)) ^(0)="^101.01PA^^"
- S DIC("DR")="2///"_$P(X0,"^",2)_";3///"_$P(X0,"^",3)_";4///"_$P(X0,"^",4)_";5///"_$P(X0,"^",5)_";6///"_$P(X0,"^",6),DLAYGO=101 D ^DIC
- I $P(Y,"^",3) W !?2,X_" added as item to "_$P(^ORD(101,DA(1),0),"^")_"."
- Q
- ACDONIT3 ;IHS/ADC/EDE/KML - NO DESCRIPTION PROVIDED;
- +1 ;;4.1;CHEMICAL DEPENDENCY MIS;;MAY 11, 1998
- +2 ;
- +3 ;
- +4 KILL ^UTILITY("ORVROM",$JOB)
- SET DIC(0)="LX"
- SET ORNMCHK=1
- IF $DATA(^ORD(101,0))#2
- IF ^(0)?1"PROTOCOL".E
- SET DIC="^ORD(101,"
- SET DLAYGO=101
- SET N="PRO"
- DO ADD
- DO OP
- +5 KILL ^UTILITY(U,$JOB),DIC,DLAYGO
- +6 QUIT
- DIEZ IF ^DD("VERSION")>17.4
- IF '$DATA(DISYS)
- IF $DATA(^%ZOSF("OS"))#2
- SET DISYS=+$PIECE(^("OS"),"^",2)
- +1 IF '$TEST
- SET DISYS=^DD("OS")
- +2 IF '$DATA(^DD("OS",DISYS,"ZS"))
- QUIT
- +3 SET N=$ORDER(^UTILITY("ORVROM",$JOB,DIR,0))
- IF N=""
- QUIT
- SET Y=+^(N)
- KILL ^(N)
- +4 IF $DATA(@("^"_DIR_"(Y,""ROU"")"))
- KILL ^("ROU")
- IF $DATA(^("ROUOLD"))
- SET X=^("ROUOLD")
- SET DMAX=^DD("ROU")
- IF X]""
- DO @("EN^DI"_$EXTRACT(DIR,3)_"Z")
- +5 GOTO DIEZ
- +6 ;
- OP SET NM=$ORDER(^UTILITY("ORVROM",$JOB,N,NM))
- IF NM=""
- KILL ^UTILITY("ORVROM",$JOB)
- GOTO Q
- +1 SET R=$ORDER(^UTILITY("ORVROM",$JOB,N,NM,0))
- IF R=""
- GOTO OP
- +2 WRITE !,"'"_NM_"' Protocol Filed"
- SET DA=+^UTILITY("ORVROM",$JOB,N,NM,R)
- +3 SET %=$PIECE(^ORD(101,DA,0),U,12)
- IF %]""
- SET %=$ORDER(^DIC(9.4,"B",%,0))
- +4 SET $PIECE(^ORD(101,DA,0),U,12)=%
- SET (ORDZ,ORDIX)=0
- +5 SET %=$SELECT($DATA(^ORD(101,DA,5)):$PIECE(^(5),"^"),1:"")
- IF $LENGTH(%)
- SET $PIECE(^(5),"^")=""
- SET X=$PIECE(%,";",2)
- SET %=$PIECE(%,";")
- IF $DATA(@("^"_X_"""B"","""_%_""")"))
- SET %=$ORDER(^(%,0))
- SET %=$SELECT(%:%_";"_X,1:"")
- SET $PIECE(^ORD(101,DA,5),"^")=%
- +6 IF $DATA(^ORD(101,DA,3,0))
- SET I=0
- FOR
- SET I=$ORDER(^ORD(101,DA,3,I))
- IF I<1
- QUIT
- SET KEY=^(I,0)
- KILL ^(0)
- IF $DATA(^DIC(19.1,"B",KEY))
- SET KEY=$ORDER(^(KEY,0))
- IF KEY
- SET ^ORD(101,DA,3,I,0)=KEY
- +7 IF $DATA(^ORD(101,DA,3))
- SET I=0
- FOR
- SET I=$ORDER(^ORD(101,DA,3,I))
- IF I<1
- QUIT
- SET ORDZ=ORDZ+1
- SET ORDIX=X
- +8 IF $TEST
- SET $PIECE(^ORD(101,DA,3,0),"^",3,4)=ORDIX_"^"_ORDZ
- +9 IF $DATA(^UTILITY("ORVROM",$JOB,N,NM,R,10))
- SET X=0
- FOR
- SET X=$ORDER(^UTILITY("ORVROM",$JOB,N,NM,R,10,X))
- IF X<1
- QUIT
- DO A1
- +10 SET (ORDZ,ORDIX)=0
- SET X=0
- FOR
- SET X=$ORDER(^ORD(101,DA,10,X))
- IF X<1
- QUIT
- SET ORDZ=ORDZ+1
- SET ORDIX=X
- +11 IF $DATA(^ORD(101,DA,10,0))
- SET ^(0)="^101.01PA^"_ORDIX_U_ORDZ
- DO IX1^DIK
- +12 IF $DATA(^UTILITY("ORVROM",$JOB,N,NM,R,"MEN"))
- SET IMEN=0
- FOR
- SET IMEN=$ORDER(^UTILITY("ORVROM",$JOB,N,NM,R,"MEN",IMEN))
- IF IMEN=""
- QUIT
- SET OMEN=^(IMEN)
- SET MEN=IMEN
- DO MEN
- +13 KILL MEN,IMEN,OMEN
- +14 GOTO OP
- +15 ;
- ADD SET R=0
- FOR
- SET R=$ORDER(^UTILITY(U,$JOB,N,R))
- IF R=""
- QUIT
- SET X=$PIECE(^(R,0),U)
- SET I=$PIECE(^(0),U,4)
- Begin DoDot:1
- +1 IF $LENGTH($TEXT(DOT^ORVOM))
- DO DOT^ORVOM
- +2 IF '$LENGTH($TEXT(DOT^ORVOM))
- WRITE "."
- +3 IF $ORDER(^ORD(101,"B",X,0))
- SET Y=$ORDER(^(0))
- SET ORA=Y
- SET Y=Y_U
- DO A
- QUIT
- +4 DO ^DIC
- IF Y>0
- IF '$DATA(DIFQ(N))!$PIECE(Y,U,3)
- SET ORA=Y
- SET Y=Y_U
- DO A
- End DoDot:1
- Q KILL ORA,MEN,OMEN,ORNMCHK,ORDZ,ORDIX
- SET (NM,R)=0
- QUIT
- A SET ^UTILITY("ORVROM",$JOB,N,X,R)=Y
- +1 IF $ORDER(^UTILITY(U,$JOB,N,R,1,0))>0
- KILL ^ORD(101,+Y,1)
- +2 IF $ORDER(^UTILITY(U,$JOB,N,R,10,0))>0
- SET %X="^UTILITY(U,$J,N,R,10,"
- SET %Y="^UTILITY(""ORVROM"",$J,N,X,R,10,"
- DO %XY^%RCR
- KILL ^UTILITY(U,$JOB,N,R,10)
- +3 IF $DATA(^UTILITY(U,$JOB,N,R,"MEN"))
- SET %X="^UTILITY(U,$J,N,R,""MEN"","
- SET %Y="^UTILITY(""ORVROM"",$J,N,X,R,""MEN"","
- DO %XY^%RCR
- KILL ^UTILITY(U,$JOB,N,R,"MEN")
- +4 SET %X="^UTILITY(U,$J,N,R,"
- SET %Y=DIC_"+ORA,"
- SET DA=+ORA
- SET DIK=DIC
- DO %XY^%RCR
- +5 QUIT
- A1 SET ORA=DA
- NEW DA,DIC,ORI
- SET Y=""
- SET ORI=0
- SET DIC="^ORD(101,"_+ORA_",10,"
- SET DIC(0)="L"
- SET DA(1)=+ORA
- IF '$DATA(^ORD(101,DA(1),10,0))
- SET ^(0)="^101.01PA^^"
- +1 FOR
- SET ORI=$ORDER(^UTILITY("ORVROM",$JOB,N,NM,R,10,ORI))
- IF ORI<1
- QUIT
- SET X0=^(ORI,0)
- SET X=$SELECT($DATA(^(U)):^(U),1:"")
- IF $LENGTH(X)
- DO A2
- +2 KILL DA,^UTILITY("ORVROM",$JOB,N,NM,R,10)
- +3 QUIT
- A2 NEW X1
- SET DLAYGO=101
- DO ^DIC
- IF 'Y
- QUIT
- +1 IF $PIECE(Y,"^",3)
- WRITE !?2,X_" added as item to "_$PIECE(^ORD(101,DA(1),0),"^")_"."
- +2 SET X0=^UTILITY("ORVROM",$JOB,N,NM,R,10,ORI,0)
- +3 SET %=$PIECE(X0,"^",4)
- IF $LENGTH(%)
- SET %=$ORDER(^ORD(101,"B",%,0))
- IF %
- SET $PIECE(X0,"^",4)=%
- +4 SET $PIECE(^ORD(101,DA(1),10,+Y,0),"^",2,99)=$PIECE(X0,"^",2,99)
- +5 SET X1=0
- FOR
- SET X1=$ORDER(^UTILITY("ORVROM",$JOB,N,NM,R,10,ORI,X1))
- IF X1=""
- QUIT
- IF X1'["^"
- SET X0=^UTILITY("ORVROM",$JOB,N,NM,R,10,ORI,X1)
- SET ^ORD(101,DA(1),10,+Y,X1)=X0
- +6 QUIT
- MEN SET MEN=$SELECT($DATA(^ORD(101,"B",MEN)):$ORDER(^(MEN,0)),1:"")
- IF 'MEN
- KILL ^UTILITY("ORVROM",$JOB,N,NM,R,"MEN")
- QUIT
- +1 SET X=NM
- SET X0=OMEN
- SET DIC="^ORD(101,"_MEN_",10,"
- SET DIC(0)="L"
- SET DA(1)=MEN
- IF '$DATA(^ORD(101,DA(1),10,0))
- SET ^(0)="^101.01PA^^"
- +2 SET DIC("DR")="2///"_$PIECE(X0,"^",2)_";3///"_$PIECE(X0,"^",3)_";4///"_$PIECE(X0,"^",4)_";5///"_$PIECE(X0,"^",5)_";6///"_$PIECE(X0,"^",6)
- SET DLAYGO=101
- DO ^DIC
- +3 IF $PIECE(Y,"^",3)
- WRITE !?2,X_" added as item to "_$PIECE(^ORD(101,DA(1),0),"^")_"."
- +4 QUIT
