DVBA2785 ;DLS/DEK - PATCH DRIVER ; 2/4/05
;;2.7;AMIE;**85**;Apr 10, 1995
; DBIA# External Reference(s)
; 2051 $$FIND1^DIC
; 2053 FILE^DIE
; 10141 BMES^XPDUTL, MES^XPDUTL
S S (C,I,J)=0,K=396.18,PA=3050120,PD=3050115,PN="85",PP=78 Q
B D S,DF,K Q ;Pre-Init (Before)
A D S,AD,K Q ;Post-Init (After)
K D:J L(">>> Review the following errors <<<"),M
K C,I,J,K,N,LN,PA,PD,PN,PP,NM,FD
Q
L(X) ;Log
S X=" "_$G(X)
I $D(XPDNM) D BMES^XPDUTL(X) Q
W !!,X
Q
M ;Messages
I $D(XPDNM) D
.K C
.M C=^TMP("DVBA",$J)
.D MES^XPDUTL(.C)
E D
.S C=$Q(^TMP("DVBA",$J))
.F Q:C="" D
..W !?3,@(C)
..S C=$Q(@C)
K ^TMP("DIERR",$J),^TMP("DVBA",$J),^TMP($J,"DVBA")
Q
DF ;Deactivate Forms
F S I=$O(^DVB(K,I)) Q:'I D CD(3,I)
Q
CD(F,IEN) ;Change Data
S IEN=IEN_","
S FD(K,IEN,F)=$S(F=2:PA,1:PD)
I F=3 D
.S N=$G(^DVB(K,+IEN,2))
.S:N=""!(PD<$P(N,U)) FD(K,IEN,2)="@"
I F=2 D
.S FD(K,IEN,3)="@",N=$G(^DVB(K,+IEN,0))
.Q:$P(N,"~",2)=PP
.D WP($G(^DVB(K,+IEN,1,1,0)))
S FD(K,IEN,7)=$S(F=2:1,1:0)
D FILE^DIE(,"FD")
Q:'$D(^TMP("DIERR",$J))
S J=J+1
M ^TMP("DVBA",$J,J)=^TMP("DIERR",$J)
Q
WP(T) Q:T=""
S ^TMP($J,"DVBA",1)=$P(T," ",1,4)
D WP^DIE(K,IEN,1,,"^TMP($J,""DVBA"")")
Q:'$D(^TMP("DIERR",$J))
S J=J+1
M ^TMP("DVBA",$J,J)=^TMP("DIERR",$J)
Q
DL(DA,DIE,DR) ;
S DA=$$FIND1^DIC(K,,"O",DA)
D:DA ^DIE
Q
AD ;Adjust Data
D DL("COLD INJURY PROTOCOL~85T1",K,".01///@")
F I=0:0 S I=$O(^DVB(K,I)) Q:'I D
.S N=$P(^(I,0),"~",2),C=C+1
.D:N=PN CD(2,I)
S I=$O(^DVB(K,"A"),-1),$P(^DVB(K,0),U,3,4)=I_U_C
;Name-specific adjustments
F I=1:1 S LN=$P($T(NS+I),";;",2) Q:LN="" D
.S NM=$P(LN,U),FD=$P(LN,U,2)
.S C=$$FIND1^DIC(K,,"O",NM)
.D:C CD(FD,C)
NS Q
;;GENERAL MEDICAL EXAMINATION~78^2
;;INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)~78^2
;;MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~78^2
;;REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)~78^2
;;AUDIO~78^2
;;AUDIO~85^3
;;AUDIO~85T1^3
;;COLD INJURY PROTOCOL~85^3
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBA2785 2055 printed Apr 09, 2024@20:54:45 Page 2
DVBA2785 ;DLS/DEK - PATCH DRIVER ; 2/4/05
+1 ;;2.7;AMIE;**85**;Apr 10, 1995
+2 ; DBIA# External Reference(s)
+3 ; 2051 $$FIND1^DIC
+4 ; 2053 FILE^DIE
+5 ; 10141 BMES^XPDUTL, MES^XPDUTL
S SET (C,I,J)=0
SET K=396.18
SET PA=3050120
SET PD=3050115
SET PN="85"
SET PP=78
QUIT
B ;Pre-Init (Before)
DO S
DO DF
DO K
QUIT
A ;Post-Init (After)
DO S
DO AD
DO K
QUIT
K if J
DO L(">>> Review the following errors <<<")
DO M
+1 KILL C,I,J,K,N,LN,PA,PD,PN,PP,NM,FD
+2 QUIT
L(X) ;Log
+1 SET X=" "_$GET(X)
+2 IF $DATA(XPDNM)
DO BMES^XPDUTL(X)
QUIT
+3 WRITE !!,X
+4 QUIT
M ;Messages
+1 IF $DATA(XPDNM)
Begin DoDot:1
+2 KILL C
+3 MERGE C=^TMP("DVBA",$JOB)
+4 DO MES^XPDUTL(.C)
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET C=$QUERY(^TMP("DVBA",$JOB))
+7 FOR
if C=""
QUIT
Begin DoDot:2
+8 WRITE !?3,@(C)
+9 SET C=$QUERY(@C)
End DoDot:2
End DoDot:1
+10 KILL ^TMP("DIERR",$JOB),^TMP("DVBA",$JOB),^TMP($JOB,"DVBA")
+11 QUIT
DF ;Deactivate Forms
+1 FOR
SET I=$ORDER(^DVB(K,I))
if 'I
QUIT
DO CD(3,I)
+2 QUIT
CD(F,IEN) ;Change Data
+1 SET IEN=IEN_","
+2 SET FD(K,IEN,F)=$SELECT(F=2:PA,1:PD)
+3 IF F=3
Begin DoDot:1
+4 SET N=$GET(^DVB(K,+IEN,2))
+5 if N=""!(PD<$PIECE(N,U))
SET FD(K,IEN,2)="@"
End DoDot:1
+6 IF F=2
Begin DoDot:1
+7 SET FD(K,IEN,3)="@"
SET N=$GET(^DVB(K,+IEN,0))
+8 if $PIECE(N,"~",2)=PP
QUIT
+9 DO WP($GET(^DVB(K,+IEN,1,1,0)))
End DoDot:1
+10 SET FD(K,IEN,7)=$SELECT(F=2:1,1:0)
+11 DO FILE^DIE(,"FD")
+12 if '$DATA(^TMP("DIERR",$JOB))
QUIT
+13 SET J=J+1
+14 MERGE ^TMP("DVBA",$JOB,J)=^TMP("DIERR",$JOB)
+15 QUIT
WP(T) if T=""
QUIT
+1 SET ^TMP($JOB,"DVBA",1)=$PIECE(T," ",1,4)
+2 DO WP^DIE(K,IEN,1,,"^TMP($J,""DVBA"")")
+3 if '$DATA(^TMP("DIERR",$JOB))
QUIT
+4 SET J=J+1
+5 MERGE ^TMP("DVBA",$JOB,J)=^TMP("DIERR",$JOB)
+6 QUIT
DL(DA,DIE,DR) ;
+1 SET DA=$$FIND1^DIC(K,,"O",DA)
+2 if DA
DO ^DIE
+3 QUIT
AD ;Adjust Data
+1 DO DL("COLD INJURY PROTOCOL~85T1",K,".01///@")
+2 FOR I=0:0
SET I=$ORDER(^DVB(K,I))
if 'I
QUIT
Begin DoDot:1
+3 SET N=$PIECE(^(I,0),"~",2)
SET C=C+1
+4 if N=PN
DO CD(2,I)
End DoDot:1
+5 SET I=$ORDER(^DVB(K,"A"),-1)
SET $PIECE(^DVB(K,0),U,3,4)=I_U_C
+6 ;Name-specific adjustments
+7 FOR I=1:1
SET LN=$PIECE($TEXT(NS+I),";;",2)
if LN=""
QUIT
Begin DoDot:1
+8 SET NM=$PIECE(LN,U)
SET FD=$PIECE(LN,U,2)
+9 SET C=$$FIND1^DIC(K,,"O",NM)
+10 if C
DO CD(FD,C)
End DoDot:1
NS QUIT
+1 ;;GENERAL MEDICAL EXAMINATION~78^2
+2 ;;INITIAL EVALUATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)~78^2
+3 ;;MENTAL DISORDERS (EXCEPT PTSD AND EATING DISORDERS)~78^2
+4 ;;REVIEW EXAMINATION FOR POST-TRAUMATIC STRESS DISORDER (PTSD)~78^2
+5 ;;AUDIO~78^2
+6 ;;AUDIO~85^3
+7 ;;AUDIO~85T1^3
+8 ;;COLD INJURY PROTOCOL~85^3
+9 ;;
