YSDX3RUA ;SLC/DJP - Print Utilities for Diagnoses Reporting in MH - Cont ;13 May 2013 9:21 AM
;;5.01;MENTAL HEALTH;**16,107**;Dec 30, 1994;Build 23
;D RECORD^YSDX0001("^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
;
AX4 ; Called by routine YSDX3R
; Print latest Axis 4 information
;D RECORD^YSDX0001("AX4^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
Q:'$D(^YSD(627.8,"AX4",YSDFN)) S A1=0 F I=1:1:1 S A1=$O(^YSD(627.8,"AX4",YSDFN,A1)) Q:'A1 S A2=0 F S A2=$O(^YSD(627.8,"AX4",YSDFN,A1,A2)) Q:'A2 D AX4P
Q
AX4P ;
;D RECORD^YSDX0001("AX4P^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
S YSPS=$P($G(^YSD(627.8,A2,60)),U) S:YSPS']"" YSPS="None given" S A3=$P(^(60),U,2),Y=$P(^(0),U,3) D DD^%DT S A9=$P(Y,"@")
S TOTSET=";"_$P(^DD(627.8,61,0),U,3),SUBSET=$F(TOTSET,";"_A3_":") I SUBSET S YSAX4=$E($P($E(TOTSET,SUBSET,999),";"),1,50) I $Y+YSSL+4>IOSL D CK^YSDX3RU Q:YSTOUT!YSUOUT!YSLFT
W !!,"AXIS IV: Psychosocial stressors: ",YSPS,!?10,"Severity: ",A3_"--"_YSAX4,!?10,"Dated: ",A9
Q
AX5 ; Called by routine YSSP6
;
;D RECORD^YSDX0001("AX5^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
Q:'$D(^YSD(627.8,"AX5",YSDFN)) S A5=$O(^YSD(627.8,"AX5",YSDFN,0)) Q:'A5 S A6=$O(^YSD(627.8,"AX5",YSDFN,A5,0)) Q:'A6 S A7=$P(^YSD(627.8,A6,60),U,3) D GAF^YSDX3UB
S Y=$P(^YSD(627.8,A6,0),U,3) D DD^%DT S A8=$P(Y,"@")
I $Y+YSSL+4>IOSL D CK^YSDX3RU Q:YSTOUT!YSUOUT!YSLFT
W !!,"AXIS V: Current GAF: ",A7_" (as of "_A8_")",!?10,"Highest GAF past year: ",$S($D(G5):G5,1:"No other GAF for past year") I $D(G5) W " (dtd "_$S($D(G11):G11,1:"Date Missing")_")",!
D FINISH^YSDX3RU
QUIT
;
DXLS ; Called by routines YSDX3R, YSPP6
; This subroutine looks up and displays the diagnosis for Length of Stay (DXLS)
;D RECORD^YSDX0001("DXLS^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
Q:'$D(^YSD(627.8,"AD",YSDFN))
S J=$O(^YSD(627.8,"AD",YSDFN,0)) ; Inverse date
DXLS1 ;
;D RECORD^YSDX0001("DXLS1^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
S J1=$O(^YSD(627.8,"AD",YSDFN,J,0)) ; IEN
S J2=$P(^YSD(627.8,+J1,1),U) ; Diag variable pointer
S (Y,YSDXLSD2)=$P(^YSD(627.8,+J1,0),U,3) D DD^%DT S YSDXLSD=Y ; Diag Date/time
S J3=$P(J2,";",2) ; Global ref
S J4=+$P(J2,";") ; IEN
S J5="^"_J3_J4_","_0_")" ; Global ref of 0 node
S J50=@J5 ; Data for 0 node
;
S YSDXCSTX=""
; DSM?
I J3["YSD" D
. S YSDXLSN=^YSD(627.7,+J4,"D") ; Diagnosis name
. S YSDXLS=$P(J50,U,1) ; ICD Code
. S YSDXCSTX="(ICD-"_$S($P(J50,U,8)'="":$P(J50,U,8),1:"9")_")"
;
; ICD9?
I J3["ICD9(" D
. N YSDXDATA S YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",J4,YSDXLSD2,"I")
. S YSDXLSN=$P(YSDXDATA,U,4) ; Diagnosis name
. S YSDXLS=$P(YSDXDATA,U,2) ; ICD Code
. S YSDXCSTX=$P($P($$SINFO^ICDEX($P(YSDXDATA,U,20)),U,2),"-",2)
. S YSDXCSTX="(ICD-"_YSDXCSTX_")"
;
I $D(YSDXLS) D
. W !!,"Principal Diagnosis (DXLS): ",!!?3
. W YSDXCSTX_" "_YSDXLS_" "_$E(YSDXLSN,1,59),!?8," dated ",YSDXLSD
;
; Modifiers?
I $D(^YSD(627.8,+J1,5)) D
. S J6=$P(^YSD(627.8,+J1,5,0),U,3) ; Stands for
. F I=1:1:J6 W !?3,"--- ",$P(^YSD(627.8,+J1,5,I,0),U,3)
;
K J1,J2,J3,J4,J5,J50,J6,YSDXCSTX,YSDXLSN,YSDXLS,YSDXLSD,YSCON
QUIT
;
EOR ;YSDX3RUA - Print Utilities for Diagnoses reporting - continued ;9/18/92 15:37
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDX3RUA 3437 printed Sep 23, 2025@19:50:24 Page 2
YSDX3RUA ;SLC/DJP - Print Utilities for Diagnoses Reporting in MH - Cont ;13 May 2013 9:21 AM
+1 ;;5.01;MENTAL HEALTH;**16,107**;Dec 30, 1994;Build 23
+2 ;D RECORD^YSDX0001("^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+3 ;
AX4 ; Called by routine YSDX3R
+1 ; Print latest Axis 4 information
+2 ;D RECORD^YSDX0001("AX4^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+3 if '$DATA(^YSD(627.8,"AX4",YSDFN))
QUIT
SET A1=0
FOR I=1:1:1
SET A1=$ORDER(^YSD(627.8,"AX4",YSDFN,A1))
if 'A1
QUIT
SET A2=0
FOR
SET A2=$ORDER(^YSD(627.8,"AX4",YSDFN,A1,A2))
if 'A2
QUIT
DO AX4P
+4 QUIT
AX4P ;
+1 ;D RECORD^YSDX0001("AX4P^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+2 SET YSPS=$PIECE($GET(^YSD(627.8,A2,60)),U)
if YSPS']""
SET YSPS="None given"
SET A3=$PIECE(^(60),U,2)
SET Y=$PIECE(^(0),U,3)
DO DD^%DT
SET A9=$PIECE(Y,"@")
+3 SET TOTSET=";"_$PIECE(^DD(627.8,61,0),U,3)
SET SUBSET=$FIND(TOTSET,";"_A3_":")
IF SUBSET
SET YSAX4=$EXTRACT($PIECE($EXTRACT(TOTSET,SUBSET,999),";"),1,50)
IF $Y+YSSL+4>IOSL
DO CK^YSDX3RU
if YSTOUT!YSUOUT!YSLFT
QUIT
+4 WRITE !!,"AXIS IV: Psychosocial stressors: ",YSPS,!?10,"Severity: ",A3_"--"_YSAX4,!?10,"Dated: ",A9
+5 QUIT
AX5 ; Called by routine YSSP6
+1 ;
+2 ;D RECORD^YSDX0001("AX5^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+3 if '$DATA(^YSD(627.8,"AX5",YSDFN))
QUIT
SET A5=$ORDER(^YSD(627.8,"AX5",YSDFN,0))
if 'A5
QUIT
SET A6=$ORDER(^YSD(627.8,"AX5",YSDFN,A5,0))
if 'A6
QUIT
SET A7=$PIECE(^YSD(627.8,A6,60),U,3)
DO GAF^YSDX3UB
+4 SET Y=$PIECE(^YSD(627.8,A6,0),U,3)
DO DD^%DT
SET A8=$PIECE(Y,"@")
+5 IF $Y+YSSL+4>IOSL
DO CK^YSDX3RU
if YSTOUT!YSUOUT!YSLFT
QUIT
+6 WRITE !!,"AXIS V: Current GAF: ",A7_" (as of "_A8_")",!?10,"Highest GAF past year: ",$SELECT($DATA(G5):G5,1:"No other GAF for past year")
IF $DATA(G5)
WRITE " (dtd "_$SELECT($DATA(G11):G11,1:"Date Missing")_")",!
+7 DO FINISH^YSDX3RU
+8 QUIT
+9 ;
DXLS ; Called by routines YSDX3R, YSPP6
+1 ; This subroutine looks up and displays the diagnosis for Length of Stay (DXLS)
+2 ;D RECORD^YSDX0001("DXLS^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+3 if '$DATA(^YSD(627.8,"AD",YSDFN))
QUIT
+4 ; Inverse date
SET J=$ORDER(^YSD(627.8,"AD",YSDFN,0))
DXLS1 ;
+1 ;D RECORD^YSDX0001("DXLS1^YSDX3RUA") ;Used for testing. Inactivated in YSDX0001...
+2 ; IEN
SET J1=$ORDER(^YSD(627.8,"AD",YSDFN,J,0))
+3 ; Diag variable pointer
SET J2=$PIECE(^YSD(627.8,+J1,1),U)
+4 ; Diag Date/time
SET (Y,YSDXLSD2)=$PIECE(^YSD(627.8,+J1,0),U,3)
DO DD^%DT
SET YSDXLSD=Y
+5 ; Global ref
SET J3=$PIECE(J2,";",2)
+6 ; IEN
SET J4=+$PIECE(J2,";")
+7 ; Global ref of 0 node
SET J5="^"_J3_J4_","_0_")"
+8 ; Data for 0 node
SET J50=@J5
+9 ;
+10 SET YSDXCSTX=""
+11 ; DSM?
+12 IF J3["YSD"
Begin DoDot:1
+13 ; Diagnosis name
SET YSDXLSN=^YSD(627.7,+J4,"D")
+14 ; ICD Code
SET YSDXLS=$PIECE(J50,U,1)
+15 SET YSDXCSTX="(ICD-"_$SELECT($PIECE(J50,U,8)'="":$PIECE(J50,U,8),1:"9")_")"
End DoDot:1
+16 ;
+17 ; ICD9?
+18 IF J3["ICD9("
Begin DoDot:1
+19 NEW YSDXDATA
SET YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",J4,YSDXLSD2,"I")
+20 ; Diagnosis name
SET YSDXLSN=$PIECE(YSDXDATA,U,4)
+21 ; ICD Code
SET YSDXLS=$PIECE(YSDXDATA,U,2)
+22 SET YSDXCSTX=$PIECE($PIECE($$SINFO^ICDEX($PIECE(YSDXDATA,U,20)),U,2),"-",2)
+23 SET YSDXCSTX="(ICD-"_YSDXCSTX_")"
End DoDot:1
+24 ;
+25 IF $DATA(YSDXLS)
Begin DoDot:1
+26 WRITE !!,"Principal Diagnosis (DXLS): ",!!?3
+27 WRITE YSDXCSTX_" "_YSDXLS_" "_$EXTRACT(YSDXLSN,1,59),!?8," dated ",YSDXLSD
End DoDot:1
+28 ;
+29 ; Modifiers?
+30 IF $DATA(^YSD(627.8,+J1,5))
Begin DoDot:1
+31 ; Stands for
SET J6=$PIECE(^YSD(627.8,+J1,5,0),U,3)
+32 FOR I=1:1:J6
WRITE !?3,"--- ",$PIECE(^YSD(627.8,+J1,5,I,0),U,3)
End DoDot:1
+33 ;
+34 KILL J1,J2,J3,J4,J5,J50,J6,YSDXCSTX,YSDXLSN,YSDXLS,YSDXLSD,YSCON
+35 QUIT
+36 ;
EOR ;YSDX3RUA - Print Utilities for Diagnoses reporting - continued ;9/18/92 15:37
