YSDX3UA ;SLC/DJP/LJA,HIOFO/FT - Utilities for Dx Entry in MH Med Rec (cont.) ;10 May 2013 2:25 PM
;;5.01;MENTAL HEALTH;**96,60,107**;Dec 30, 1994;Build 23
;
;Reference to ^VA(200, supported by DBIA #10060
;Reference to ^ICD9( supported by DBIA #5388
;Reference to ^ICDCODE APIs supported by DBIA #3990
;
;D RECORD^YSDX0001("^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
;
DSMLK ; Called by routine YSDX3
; Keywork lookup for DSM
;D RECORD^YSDX0001("DSMLK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S X=$P(X1," ") G:$P(X1," ",2)="" LK1
S Q=$C(34),D="S A=^(1) I "
F I=2:1 S B=$P(X1," ",I) Q:B="" S:B'[Q D=D_"(A["" "_B_""")&"
S DIC("S")=$E(D,1,$L(D)-1)
LK1 ;
;D RECORD^YSDX0001("LK1^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S DIC("S")="I $P(^(0),U,2)=4" ;Allow DSM-IV selection only...
S DIC(0)="QMZE",DIC="^YSD(627.7,"
D ^DIC
K DIC("S")
QUIT
;
DSMP ; Called by routine YSDX3
;D RECORD^YSDX0001("DSMP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
I '$D(P2) W " ?? " W @IOF G AGAIN^YSDX3
S S1=$P(^YSD(627.8,P2(X1),1),U),S2=$P(S1,";"),YSY=1
QUIT
;
;
ICDLK ; Called from YSDX3A
; Lookup on the ICD9 File
;D RECORD^YSDX0001("ICDLK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S X=$P(X2," ") G:$P(X2," ",2)="" ICD1
S Q=$C(34),D="S A=$C(32)_^(1) I "
F I=2:1 S B=$P(X2," ",I) Q:B="" S:B'[Q D=D_"(A["" "_B_""")&"
S DIC("S")=$E(D,1,$L(D)-1)
ICD1 ;
;D RECORD^YSDX0001("ICD1^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S (X,Y)=X2
S DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,YSDXDAT),U,10)=1"
S DIC(0)="QMZE",DIC="^ICD9("
S ICDVDT=$P(YSDXDAT,".",1) D ^DIC
K DIC("S"),ICDVDT
QUIT
;
ICDP ; Called by routine YSDX3A
;D RECORD^YSDX0001("ICDP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S S1=$P(^YSD(627.8,P2(X2),1),U),S2=$$ICDDATA^ICDXCODE("DIAG",$P(S1,";"),YSDXDAT,"I"),S2=$P(S2,U,2),YSY=1 ;ASF 04/10/09
QUIT
;
DXLS D DXLS^YSDX3UA0
QUIT
;
DXLSQ D DXLSQ^YSDX3UA0
QUIT
;
DUPL ; Called by routine YSDX3, YSDX3A
; Print out information concerning duplicate entry
;D RECORD^YSDX0001("DUPL^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S W3=$P(^VA(200,$P(^YSD(627.8,W2,0),U,4),0),U)
N YSDZX
S Y=$P(^YSD(627.8,W2,0),U,3) D DD^%DT S W4=Y
I YSAX=1 S YSDXND=$P(^YSD(627.7,S2,0),U),YSDXD=$P(^(0),U)
I YSAX=3 D
. S YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",S2,YSDXDAT,"I")
. S YSDXD=$P(YSDXDATA,U,2)
. N YSDXZ S YSDZX=$$ICDDESC^ICDXCODE($P(YSACSREC,U,1),YSDXD,YSDXDAT,.YSDZX),YSDXND=YSDZX(1)
S W5=$P(^YSD(627.8,W2,1),U,2)
I W5="i" K YSDXND,YSDXD,W3,W4,W5 QUIT ;->
S W6=$S(W5="v":"VERIFIED",W5="p":"PROVISIONAL",W5="i":"INACTIVE",W5="r":"REFORMULATED",W5="n":"NOT FOUND",W5="ru":"RULE OUT",1:"")
DUPLP ;
;D RECORD^YSDX0001("DUPLP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
I '$D(YSF1) D
. W !!,"This diagnosis has been entered as follows: "
. W !!?5,"DIAGNOSIS: ",?15,YSDXND_" "_YSDXD,!?5,"STATUS:"
. W ?13,W6,!?5,"BY:",?13,$E(W3,1,25)_" on "_W4,!
S YSF1=1
QUIT
;
FILE ; Called from routines YSDX3, YSDX3A
;D RECORD^YSDX0001("FILE^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S YSDUZ=$P(^VA(200,DUZ,0),U)
W !
S DIE=DIC,DA=YSDA,DR=".02////"_YSDFN_";.03////"_YSDXDAT_";.04//"_YSDUZ_";.05///^S X=""`""_DUZ;1////^S X=YSDXDA;5"
L +@(DIE_"DA)"):DILOCKTM
I '$T D ERRMSG^YSSITE,DELETE Q
D ^DIE
L -@(DIE_"DA)")
S YSTOUT=$D(DTOUT) I YSTOUT D DELETE QUIT ;->
D CHECK QUIT:YSUOUT ;->
S C1=$P(^YSD(627.8,YSDA,1),U,2)
I C1="" W !!?18,"Incomplete information." D DELETE QUIT ;->
S C2=$S(C1="v":"A",C1="p":"A",C1="i":"I",C1="r":"I",C1="n":"I",C1="ru":"A",1:"I")
S DIE="^YSD(627.8,",DA=YSDA,DR="7///^S X=C2;8///NOW"
L +^YSD(627.8,DA):DILOCKTM
I '$T D ERRMSG^YSSITE Q
D ^DIE
L -^YSD(627.8,DA)
K DIE
S YSTOUT=$D(DTOUT) I YSTOUT QUIT ;->
D CHECK QUIT:YSUOUT ;->
N YSTO S YSTO=0
I $D(W3) D Q:YSTO
. S DIE="^YSD(627.8,",DA=YSDUPDA
. S DR="7///^S X=""I"";8///NOW;9///^S X=""Y"""
. L +^YSD(627.8,DA):DILOCKTM
. I '$T D ERRMSG^YSSITE S YSTO=1 Q
. D ^DIE
. L -^YSD(627.8,DA)
D DXLS,DXLSQ
S DIE="^YSD(627.8,",DA=YSDA
S DR="10///^S X=YSDXLX;80"
L +^YSD(627.8,DA):DILOCKTM
I '$T D ERRMSG^YSSITE Q
D ^DIE
L -^YSD(627.8,DA)
S YSTOUT=$D(DTOUT) QUIT:YSTOUT ;->
D CHECK QUIT:YSUOUT ;->
FILEQ ;
;D RECORD^YSDX0001("FILEQ^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S %=0
F Q:$G(%) W !!," Do you want to record this diagnosis" S %=1 D
. D YN^DICN
. I '% W !!,"NO will delete this entry. YES will file it under the patient's name."
I %=2!(%=-1) D DELETE
QUIT
;
CHECK ;
;D RECORD^YSDX0001("CHECK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S YSUOUT=$O(Y(""))]"" I 'YSUOUT QUIT ;->
W !!?18,"Incomplete information."
;
DELETE ; Called by routine YSDX3UB
;D RECORD^YSDX0001("DELETE^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
S DIK="^YSD(627.8,",DA=YSDA
D ^DIK
W !!?15,"< This diagnosis deleted. >"
QUIT
;
EOR ;YSDX3UA - Utilities for Diagnosis Entry in the MH Medical Record (cont.) ;4/16/92 11:17
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDX3UA 5186 printed Sep 23, 2025@19:50:27 Page 2
YSDX3UA ;SLC/DJP/LJA,HIOFO/FT - Utilities for Dx Entry in MH Med Rec (cont.) ;10 May 2013 2:25 PM
+1 ;;5.01;MENTAL HEALTH;**96,60,107**;Dec 30, 1994;Build 23
+2 ;
+3 ;Reference to ^VA(200, supported by DBIA #10060
+4 ;Reference to ^ICD9( supported by DBIA #5388
+5 ;Reference to ^ICDCODE APIs supported by DBIA #3990
+6 ;
+7 ;D RECORD^YSDX0001("^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+8 ;
DSMLK ; Called by routine YSDX3
+1 ; Keywork lookup for DSM
+2 ;D RECORD^YSDX0001("DSMLK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+3 SET X=$PIECE(X1," ")
if $PIECE(X1," ",2)=""
GOTO LK1
+4 SET Q=$CHAR(34)
SET D="S A=^(1) I "
+5 FOR I=2:1
SET B=$PIECE(X1," ",I)
if B=""
QUIT
if B'[Q
SET D=D_"(A["" "_B_""")&"
+6 SET DIC("S")=$EXTRACT(D,1,$LENGTH(D)-1)
LK1 ;
+1 ;D RECORD^YSDX0001("LK1^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 ;Allow DSM-IV selection only...
SET DIC("S")="I $P(^(0),U,2)=4"
+3 SET DIC(0)="QMZE"
SET DIC="^YSD(627.7,"
+4 DO ^DIC
+5 KILL DIC("S")
+6 QUIT
+7 ;
DSMP ; Called by routine YSDX3
+1 ;D RECORD^YSDX0001("DSMP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 IF '$DATA(P2)
WRITE " ?? "
WRITE @IOF
GOTO AGAIN^YSDX3
+3 SET S1=$PIECE(^YSD(627.8,P2(X1),1),U)
SET S2=$PIECE(S1,";")
SET YSY=1
+4 QUIT
+5 ;
+6 ;
ICDLK ; Called from YSDX3A
+1 ; Lookup on the ICD9 File
+2 ;D RECORD^YSDX0001("ICDLK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+3 SET X=$PIECE(X2," ")
if $PIECE(X2," ",2)=""
GOTO ICD1
+4 SET Q=$CHAR(34)
SET D="S A=$C(32)_^(1) I "
+5 FOR I=2:1
SET B=$PIECE(X2," ",I)
if B=""
QUIT
if B'[Q
SET D=D_"(A["" "_B_""")&"
+6 SET DIC("S")=$EXTRACT(D,1,$LENGTH(D)-1)
ICD1 ;
+1 ;D RECORD^YSDX0001("ICD1^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 SET (X,Y)=X2
+3 SET DIC("S")="I $P($$ICDDATA^ICDXCODE(""DIAG"",Y,YSDXDAT),U,10)=1"
+4 SET DIC(0)="QMZE"
SET DIC="^ICD9("
+5 SET ICDVDT=$PIECE(YSDXDAT,".",1)
DO ^DIC
+6 KILL DIC("S"),ICDVDT
+7 QUIT
+8 ;
ICDP ; Called by routine YSDX3A
+1 ;D RECORD^YSDX0001("ICDP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 ;ASF 04/10/09
SET S1=$PIECE(^YSD(627.8,P2(X2),1),U)
SET S2=$$ICDDATA^ICDXCODE("DIAG",$PIECE(S1,";"),YSDXDAT,"I")
SET S2=$PIECE(S2,U,2)
SET YSY=1
+3 QUIT
+4 ;
DXLS DO DXLS^YSDX3UA0
+1 QUIT
+2 ;
DXLSQ DO DXLSQ^YSDX3UA0
+1 QUIT
+2 ;
DUPL ; Called by routine YSDX3, YSDX3A
+1 ; Print out information concerning duplicate entry
+2 ;D RECORD^YSDX0001("DUPL^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+3 SET W3=$PIECE(^VA(200,$PIECE(^YSD(627.8,W2,0),U,4),0),U)
+4 NEW YSDZX
+5 SET Y=$PIECE(^YSD(627.8,W2,0),U,3)
DO DD^%DT
SET W4=Y
+6 IF YSAX=1
SET YSDXND=$PIECE(^YSD(627.7,S2,0),U)
SET YSDXD=$PIECE(^(0),U)
+7 IF YSAX=3
Begin DoDot:1
+8 SET YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",S2,YSDXDAT,"I")
+9 SET YSDXD=$PIECE(YSDXDATA,U,2)
+10 NEW YSDXZ
SET YSDZX=$$ICDDESC^ICDXCODE($PIECE(YSACSREC,U,1),YSDXD,YSDXDAT,.YSDZX)
SET YSDXND=YSDZX(1)
End DoDot:1
+11 SET W5=$PIECE(^YSD(627.8,W2,1),U,2)
+12 ;->
IF W5="i"
KILL YSDXND,YSDXD,W3,W4,W5
QUIT
+13 SET W6=$SELECT(W5="v":"VERIFIED",W5="p":"PROVISIONAL",W5="i":"INACTIVE",W5="r":"REFORMULATED",W5="n":"NOT FOUND",W5="ru":"RULE OUT",1:"")
DUPLP ;
+1 ;D RECORD^YSDX0001("DUPLP^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 IF '$DATA(YSF1)
Begin DoDot:1
+3 WRITE !!,"This diagnosis has been entered as follows: "
+4 WRITE !!?5,"DIAGNOSIS: ",?15,YSDXND_" "_YSDXD,!?5,"STATUS:"
+5 WRITE ?13,W6,!?5,"BY:",?13,$EXTRACT(W3,1,25)_" on "_W4,!
End DoDot:1
+6 SET YSF1=1
+7 QUIT
+8 ;
FILE ; Called from routines YSDX3, YSDX3A
+1 ;D RECORD^YSDX0001("FILE^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 SET YSDUZ=$PIECE(^VA(200,DUZ,0),U)
+3 WRITE !
+4 SET DIE=DIC
SET DA=YSDA
SET DR=".02////"_YSDFN_";.03////"_YSDXDAT_";.04//"_YSDUZ_";.05///^S X=""`""_DUZ;1////^S X=YSDXDA;5"
+5 LOCK +@(DIE_"DA)"):DILOCKTM
+6 IF '$TEST
DO ERRMSG^YSSITE
DO DELETE
QUIT
+7 DO ^DIE
+8 LOCK -@(DIE_"DA)")
+9 ;->
SET YSTOUT=$DATA(DTOUT)
IF YSTOUT
DO DELETE
QUIT
+10 ;->
DO CHECK
if YSUOUT
QUIT
+11 SET C1=$PIECE(^YSD(627.8,YSDA,1),U,2)
+12 ;->
IF C1=""
WRITE !!?18,"Incomplete information."
DO DELETE
QUIT
+13 SET C2=$SELECT(C1="v":"A",C1="p":"A",C1="i":"I",C1="r":"I",C1="n":"I",C1="ru":"A",1:"I")
+14 SET DIE="^YSD(627.8,"
SET DA=YSDA
SET DR="7///^S X=C2;8///NOW"
+15 LOCK +^YSD(627.8,DA):DILOCKTM
+16 IF '$TEST
DO ERRMSG^YSSITE
QUIT
+17 DO ^DIE
+18 LOCK -^YSD(627.8,DA)
+19 KILL DIE
+20 ;->
SET YSTOUT=$DATA(DTOUT)
IF YSTOUT
QUIT
+21 ;->
DO CHECK
if YSUOUT
QUIT
+22 NEW YSTO
SET YSTO=0
+23 IF $DATA(W3)
Begin DoDot:1
+24 SET DIE="^YSD(627.8,"
SET DA=YSDUPDA
+25 SET DR="7///^S X=""I"";8///NOW;9///^S X=""Y"""
+26 LOCK +^YSD(627.8,DA):DILOCKTM
+27 IF '$TEST
DO ERRMSG^YSSITE
SET YSTO=1
QUIT
+28 DO ^DIE
+29 LOCK -^YSD(627.8,DA)
End DoDot:1
if YSTO
QUIT
+30 DO DXLS
DO DXLSQ
+31 SET DIE="^YSD(627.8,"
SET DA=YSDA
+32 SET DR="10///^S X=YSDXLX;80"
+33 LOCK +^YSD(627.8,DA):DILOCKTM
+34 IF '$TEST
DO ERRMSG^YSSITE
QUIT
+35 DO ^DIE
+36 LOCK -^YSD(627.8,DA)
+37 ;->
SET YSTOUT=$DATA(DTOUT)
if YSTOUT
QUIT
+38 ;->
DO CHECK
if YSUOUT
QUIT
FILEQ ;
+1 ;D RECORD^YSDX0001("FILEQ^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 SET %=0
+3 FOR
if $GET(%)
QUIT
WRITE !!," Do you want to record this diagnosis"
SET %=1
Begin DoDot:1
+4 DO YN^DICN
+5 IF '%
WRITE !!,"NO will delete this entry. YES will file it under the patient's name."
End DoDot:1
+6 IF %=2!(%=-1)
DO DELETE
+7 QUIT
+8 ;
CHECK ;
+1 ;D RECORD^YSDX0001("CHECK^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 ;->
SET YSUOUT=$ORDER(Y(""))]""
IF 'YSUOUT
QUIT
+3 WRITE !!?18,"Incomplete information."
+4 ;
DELETE ; Called by routine YSDX3UB
+1 ;D RECORD^YSDX0001("DELETE^YSDX3UA") ;Used for testing. Inactivated in YSDX0001...
+2 SET DIK="^YSD(627.8,"
SET DA=YSDA
+3 DO ^DIK
+4 WRITE !!?15,"< This diagnosis deleted. >"
+5 QUIT
+6 ;
EOR ;YSDX3UA - Utilities for Diagnosis Entry in the MH Medical Record (cont.) ;4/16/92 11:17
