YSDX3A ;SLC/DJP - Entry of Axis 3 Diagnosis for the Mental Health Med Rec ; 17 Oct 2014 9:46 AM
;;5.01;MENTAL HEALTH;**33,107,117**;Dec 30, 1994;Build 1
;D RECORD^YSDX0001("YSDX3A^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
;
; Called from routines YSCEN1, YSDX3
AXIS3 ;
;D RECORD^YSDX0001("AXIS3^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
K YSDXDA,YSDA,YSDTY,YSNO,P1 W @IOF,!!?10,"ENTRY OF DIAGNOSIS - Continued - ",$E(YSNM,1,25) S YSAX=3,YSDTY="A",P1=0 K P2 W !!,"ACTIVE ICD DIAGNOSES (Axis 3): ",! D LIST^YSDX3U G:$D(YSNO) QUES2
I '$D(YSDXN) W !!?3,"No active ICD diagnosis on file for ",YSNM,".",!
D INQ^YSDX3U Q:$D(YSQT)
QUES2 ;Subroutine presents questions for Axis 3
;D RECORD^YSDX0001("QUES2^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
I $G(YSDXDAT)="" S YSDXDAT=DT
N YSACSREC,YSACS S YSACSREC=$$ACTDT^YSDXUTL(YSDXDAT),YSACS=$P(YSACSREC,U,3)
I YSACS["-" S YSACS=$P(YSACS,"-",1,2)
I '$D(^XUSEC("YSD",DUZ)) W !!,"You must hold correct security key to enter ",YSACS," diagnosis." Q
I $P(YSACSREC,U,1)'="ICD" D G:$G(X2)?1N.N QUES2B G:YSRETV'<0 DUPLCK
. K X2 S YSDT=YSDXDAT D EN^YSLXDG Q:YSRETV<0 I $P(YSRETV,U,1)?.N S X2=$P(YSRETV,U,1)
. S (YSDXDA,Y)=$P($$ICDDATA^ICDXCODE("DIAG",$P($P(YSRETV,U,1),";",2),YSDXDAT,"E"),U,1)
I $G(YSRETV)<0 K YSRETV Q
W !!,"Enter ",YSACS," DIAGNOSIS: " R X2:DTIME S YSTOUT='$T,YSUOUT=X2["^" I YSTOUT!YSUOUT S YSQT=1 Q
QUES2B Q:X2=""
I X2="???" S X2="??"
I X2?.N I X2<(P1+1) D ICDP^YSDX3UA G:'$D(YSY) QUES2 S:$D(S1) YSDXDA=$P(S1,";")
I '$D(YSY) S X2=$$UP^XLFSTR(X2) D ICDLK^YSDX3UA G:Y<0 QUES2
DUPLCK ;Checks for and displays possible duplicate entries
;D RECORD^YSDX0001("DUPLCK^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
S:'$D(YSDXDA) YSDXDA=+Y S:'$D(S2) S2=+Y S W2="",W1=S2_";"_"ICD9(" F I=1:1 S W2=$O(^YSD(627.8,"AG","I",YSDFN,W1,W2)) Q:W2="" S YSDUPDA=W2 D DUPL^YSDX3UA
CORR ;
;D RECORD^YSDX0001("CORR^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
N YSDXDATA S YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",YSDXDA,YSDXDAT,"I")
I $P(YSDXDATA,U,1)=-1 W !!,"Invalid Diagnosis for DATE/TIME OF DIAGNOSIS that was entered." K YSY G QUES2
;S YSW=$P(^ICD9(YSDXDA,0),U),YSWN=$P(^(0),U,3)
S YSW=$P(YSDXDATA,U,2),YSWN=$P(YSDXDATA,U,4)
S %=0 F Q:$G(%) W !!?10,YSW_" "_YSWN,!!,"Is this the ICD diagnosis you wish to select" S %=2 D
.D YN^DICN S YSTOUT=$D(DTOUT),YSUOUT=$D(DUOUT) I YSTOUT!YSUOUT Q
.I '% W !!,"""YES"" indicates the diagnosis entered applies to ",YSNM,"."
I %=2 K YSDXDA,YSY,X2,S2 G QUES2
Q:%=-1
FILE ;
;D RECORD^YSDX0001("FILE^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
;S DIC="^YSD(627.8,",DIC(0)="L",X="""N""",DLAYGO=627 D ^DIC Q:Y'>0 S YSDA=+Y,YSDXDA=YSDXDA_";ICD9("
K DD,DO,DA,DINUM
S X="NOW",%DT="TR" D ^%DT S X=Y
S DIC="^YSD(627.8,",DIC(0)="L",DLAYGO=627.8 D FILE^DICN Q:Y'>0 S YSDA=+Y,YSDXDA=YSDXDA_";ICD9("
D FILE^YSDX3UA
K YSDXDA,YSDA,YSDTY,YSDXDA1,YSDXDT,YSDXN,YSDXNN,YSDXST,YSMOD,YSW,YSWN,YSALZ,YSY,F1,F2,F3,K1,K2,K3,K4,K5,K6,L2,L3,L4,L5,L7,P3,P4,P5,S2,W1,W2,W3,W4,W5,W6,X,X2 G:'$D(YSPLIC) QUES2
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDX3A 3110 printed Sep 23, 2025@19:50:19 Page 2
YSDX3A ;SLC/DJP - Entry of Axis 3 Diagnosis for the Mental Health Med Rec ; 17 Oct 2014 9:46 AM
+1 ;;5.01;MENTAL HEALTH;**33,107,117**;Dec 30, 1994;Build 1
+2 ;D RECORD^YSDX0001("YSDX3A^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+3 ;
+4 ; Called from routines YSCEN1, YSDX3
AXIS3 ;
+1 ;D RECORD^YSDX0001("AXIS3^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+2 KILL YSDXDA,YSDA,YSDTY,YSNO,P1
WRITE @IOF,!!?10,"ENTRY OF DIAGNOSIS - Continued - ",$EXTRACT(YSNM,1,25)
SET YSAX=3
SET YSDTY="A"
SET P1=0
KILL P2
WRITE !!,"ACTIVE ICD DIAGNOSES (Axis 3): ",!
DO LIST^YSDX3U
if $DATA(YSNO)
GOTO QUES2
+3 IF '$DATA(YSDXN)
WRITE !!?3,"No active ICD diagnosis on file for ",YSNM,".",!
+4 DO INQ^YSDX3U
if $DATA(YSQT)
QUIT
QUES2 ;Subroutine presents questions for Axis 3
+1 ;D RECORD^YSDX0001("QUES2^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+2 IF $GET(YSDXDAT)=""
SET YSDXDAT=DT
+3 NEW YSACSREC,YSACS
SET YSACSREC=$$ACTDT^YSDXUTL(YSDXDAT)
SET YSACS=$PIECE(YSACSREC,U,3)
+4 IF YSACS["-"
SET YSACS=$PIECE(YSACS,"-",1,2)
+5 IF '$DATA(^XUSEC("YSD",DUZ))
WRITE !!,"You must hold correct security key to enter ",YSACS," diagnosis."
QUIT
+6 IF $PIECE(YSACSREC,U,1)'="ICD"
Begin DoDot:1
+7 KILL X2
SET YSDT=YSDXDAT
DO EN^YSLXDG
if YSRETV<0
QUIT
IF $PIECE(YSRETV,U,1)?.N
SET X2=$PIECE(YSRETV,U,1)
+8 SET (YSDXDA,Y)=$PIECE($$ICDDATA^ICDXCODE("DIAG",$PIECE($PIECE(YSRETV,U,1),";",2),YSDXDAT,"E"),U,1)
End DoDot:1
if $GET(X2)?1N.N
GOTO QUES2B
if YSRETV'<0
GOTO DUPLCK
+9 IF $GET(YSRETV)<0
KILL YSRETV
QUIT
+10 WRITE !!,"Enter ",YSACS," DIAGNOSIS: "
READ X2:DTIME
SET YSTOUT='$TEST
SET YSUOUT=X2["^"
IF YSTOUT!YSUOUT
SET YSQT=1
QUIT
QUES2B if X2=""
QUIT
+1 IF X2="???"
SET X2="??"
+2 IF X2?.N
IF X2<(P1+1)
DO ICDP^YSDX3UA
if '$DATA(YSY)
GOTO QUES2
if $DATA(S1)
SET YSDXDA=$PIECE(S1,";")
+3 IF '$DATA(YSY)
SET X2=$$UP^XLFSTR(X2)
DO ICDLK^YSDX3UA
if Y<0
GOTO QUES2
DUPLCK ;Checks for and displays possible duplicate entries
+1 ;D RECORD^YSDX0001("DUPLCK^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+2 if '$DATA(YSDXDA)
SET YSDXDA=+Y
if '$DATA(S2)
SET S2=+Y
SET W2=""
SET W1=S2_";"_"ICD9("
FOR I=1:1
SET W2=$ORDER(^YSD(627.8,"AG","I",YSDFN,W1,W2))
if W2=""
QUIT
SET YSDUPDA=W2
DO DUPL^YSDX3UA
CORR ;
+1 ;D RECORD^YSDX0001("CORR^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+2 NEW YSDXDATA
SET YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",YSDXDA,YSDXDAT,"I")
+3 IF $PIECE(YSDXDATA,U,1)=-1
WRITE !!,"Invalid Diagnosis for DATE/TIME OF DIAGNOSIS that was entered."
KILL YSY
GOTO QUES2
+4 ;S YSW=$P(^ICD9(YSDXDA,0),U),YSWN=$P(^(0),U,3)
+5 SET YSW=$PIECE(YSDXDATA,U,2)
SET YSWN=$PIECE(YSDXDATA,U,4)
+6 SET %=0
FOR
if $GET(%)
QUIT
WRITE !!?10,YSW_" "_YSWN,!!,"Is this the ICD diagnosis you wish to select"
SET %=2
Begin DoDot:1
+7 DO YN^DICN
SET YSTOUT=$DATA(DTOUT)
SET YSUOUT=$DATA(DUOUT)
IF YSTOUT!YSUOUT
QUIT
+8 IF '%
WRITE !!,"""YES"" indicates the diagnosis entered applies to ",YSNM,"."
End DoDot:1
+9 IF %=2
KILL YSDXDA,YSY,X2,S2
GOTO QUES2
+10 if %=-1
QUIT
FILE ;
+1 ;D RECORD^YSDX0001("FILE^YSDX3A") ;Used for testing. Inactivated in YSDX0001...
+2 ;S DIC="^YSD(627.8,",DIC(0)="L",X="""N""",DLAYGO=627 D ^DIC Q:Y'>0 S YSDA=+Y,YSDXDA=YSDXDA_";ICD9("
+3 KILL DD,DO,DA,DINUM
+4 SET X="NOW"
SET %DT="TR"
DO ^%DT
SET X=Y
+5 SET DIC="^YSD(627.8,"
SET DIC(0)="L"
SET DLAYGO=627.8
DO FILE^DICN
if Y'>0
QUIT
SET YSDA=+Y
SET YSDXDA=YSDXDA_";ICD9("
+6 DO FILE^YSDX3UA
+7 KILL YSDXDA,YSDA,YSDTY,YSDXDA1,YSDXDT,YSDXN,YSDXNN,YSDXST,YSMOD,YSW,YSWN,YSALZ,YSY,F1,F2,F3,K1,K2,K3,K4,K5,K6,L2,L3,L4,L5,L7,P3,P4,P5,S2,W1,W2,W3,W4,W5,W6,X,X2
if '$DATA(YSPLIC)
GOTO QUES2
