- DVBA2789 ;DLS/DEK - PATCH DRIVER ; 2/24/05
- ;;2.7;AMIE;**89**;Apr 10, 1995
- ;
- ; DBIA# External Reference(s)
- ; 2051 $$FIND1^DIC
- ; 2053 FILE^DIE
- ; 10103 $$FMADD^XLFDT
- ; 10141 BMES^XPDUTL, MES^XPDUTL
- S S N=89,(C,I,J)=0,K=396.18,T="~",E="DIERR",M="DVBA",B=$$FMADD^XLFDT(DT,-9) Q
- B D S,0 G K ;Pre
- A D S,1 ;Post
- K D:J L(">>>>> Review these errors <<<<<")
- K A,B,C,H,I,J,K,L,N,P,R,S,T,V,^TMP(M,$J),^TMP(E,$J),M,E
- Q
- 3 S A(K,IEN,2)="@",A(K,IEN,7)=0,A(K,IEN,F)=B Q
- 2 S A(K,IEN,3)="@",A(K,IEN,7)=1,A(K,IEN,F)=DT Q
- C(F,IEN) Q:F=3&$P($G(^DVB(K,IEN,2)),U,2) S IEN=IEN_"," D @F,FILE^DIE(,"A")
- I $D(^TMP(E,$J)) S J=J+1 M ^TMP(M,$J,J)=^TMP(E,$J)
- Q
- L(X) I $D(XPDNM) K C M C=^TMP(M,$J) D BMES^XPDUTL(X),MES^XPDUTL(.C) Q
- S I="""",J=","_$J,R=M_I_J,T="^TMP("_I_E_I_J_","
- W !!,X S C=$Q(^TMP(M,$J)) F Q:C'[R W !?3,T,$P(C,",",3,99)," = ",@C S C=$Q(@C)
- Q
- Z(DA,F) S DA=$$FIND1^DIC(K,,"O",DA) D:DA&F C(F,DA) Q
- 0 F S I=$O(^DVB(K,I)) Q:'I S C=$P(^(I,0),T,2) D:C["T" C(3,I)
- Q
- 1 F I=1:1 S L=$P($T(N+I),";;",2) Q:L="" D Z($P(L,U),$P(L,U,2))
- F S L=$O(^DVB(K,+L)) Q:'L S V=^(L,0),C=C+1 D:$P(V,T,2)=N V
- S $P(^DVB(K,0),U,3,4)=+$O(^DVB(K," "),-1)_U_C
- Q
- V S V=$P($E(V,1,30),T),S=$E(V,1,$L(V)-1)_$C($A($E(V,$L(V)))-1)
- F S S=$O(^DVB(K,"B",S)) Q:S=""!(S'[V) D
- .F H=0:0 S H=$O(^DVB(K,"B",S,H)) Q:'H D C(H'=L+2,H)
- N Q ;Named de/activations
- ;;AUDIO~85^3
- ;;COLD INJURY PROTOCOL~85^3
- ;;AUDIO~88^3
- ;;JOINTS~85^2
- ;;SPINE~85^2
- ;;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA2789 1466 printed Apr 23, 2025@17:54:09 Page 2
- DVBA2789 ;DLS/DEK - PATCH DRIVER ; 2/24/05
- +1 ;;2.7;AMIE;**89**;Apr 10, 1995
- +2 ;
- +3 ; DBIA# External Reference(s)
- +4 ; 2051 $$FIND1^DIC
- +5 ; 2053 FILE^DIE
- +6 ; 10103 $$FMADD^XLFDT
- +7 ; 10141 BMES^XPDUTL, MES^XPDUTL
- S SET N=89
- SET (C,I,J)=0
- SET K=396.18
- SET T="~"
- SET E="DIERR"
- SET M="DVBA"
- SET B=$$FMADD^XLFDT(DT,-9)
- QUIT
- B ;Pre
- DO S
- DO 0
- GOTO K
- A ;Post
- DO S
- DO 1
- K if J
- DO L(">>>>> Review these errors <<<<<")
- +1 KILL A,B,C,H,I,J,K,L,N,P,R,S,T,V,^TMP(M,$JOB),^TMP(E,$JOB),M,E
- +2 QUIT
- 3 SET A(K,IEN,2)="@"
- SET A(K,IEN,7)=0
- SET A(K,IEN,F)=B
- QUIT
- 2 SET A(K,IEN,3)="@"
- SET A(K,IEN,7)=1
- SET A(K,IEN,F)=DT
- QUIT
- C(F,IEN) if F=3&$PIECE($GET(^DVB(K,IEN,2)),U,2)
- QUIT
- SET IEN=IEN_","
- DO @F
- DO FILE^DIE(,"A")
- +1 IF $DATA(^TMP(E,$JOB))
- SET J=J+1
- MERGE ^TMP(M,$JOB,J)=^TMP(E,$JOB)
- +2 QUIT
- L(X) IF $DATA(XPDNM)
- KILL C
- MERGE C=^TMP(M,$JOB)
- DO BMES^XPDUTL(X)
- DO MES^XPDUTL(.C)
- QUIT
- +1 SET I=""""
- SET J=","_$JOB
- SET R=M_I_J
- SET T="^TMP("_I_E_I_J_","
- +2 WRITE !!,X
- SET C=$QUERY(^TMP(M,$JOB))
- FOR
- if C'[R
- QUIT
- WRITE !?3,T,$PIECE(C,",",3,99)," = ",@C
- SET C=$QUERY(@C)
- +3 QUIT
- Z(DA,F) SET DA=$$FIND1^DIC(K,,"O",DA)
- if DA&F
- DO C(F,DA)
- QUIT
- 0 FOR
- SET I=$ORDER(^DVB(K,I))
- if 'I
- QUIT
- SET C=$PIECE(^(I,0),T,2)
- if C["T"
- DO C(3,I)
- +1 QUIT
- 1 FOR I=1:1
- SET L=$PIECE($TEXT(N+I),";;",2)
- if L=""
- QUIT
- DO Z($PIECE(L,U),$PIECE(L,U,2))
- +1 FOR
- SET L=$ORDER(^DVB(K,+L))
- if 'L
- QUIT
- SET V=^(L,0)
- SET C=C+1
- if $PIECE(V,T,2)=N
- DO V
- +2 SET $PIECE(^DVB(K,0),U,3,4)=+$ORDER(^DVB(K," "),-1)_U_C
- +3 QUIT
- V SET V=$PIECE($EXTRACT(V,1,30),T)
- SET S=$EXTRACT(V,1,$LENGTH(V)-1)_$CHAR($ASCII($EXTRACT(V,$LENGTH(V)))-1)
- +1 FOR
- SET S=$ORDER(^DVB(K,"B",S))
- if S=""!(S'[V)
- QUIT
- Begin DoDot:1
- +2 FOR H=0:0
- SET H=$ORDER(^DVB(K,"B",S,H))
- if 'H
- QUIT
- DO C(H'=L+2,H)
- End DoDot:1
- N ;Named de/activations
- QUIT
- +1 ;;AUDIO~85^3
- +2 ;;COLD INJURY PROTOCOL~85^3
- +3 ;;AUDIO~88^3
- +4 ;;JOINTS~85^2
- +5 ;;SPINE~85^2
- +6 ;;
