YSDX3R1 ;SLC/DJP/LJA - Print of DXLS History for Mental Health Med Rec ;10 May 2013 4:05 PM
;;5.01;MENTAL HEALTH;**107**;Dec 30, 1994;Build 23
;
; Called from the top by MENU option YSDIAGP-DXLS
;D RECORD^YSDX0001("YSDX3R1^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
;
ENTRY ;
;D RECORD^YSDX0001("ENTRY^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
W @IOF W !!?IOM-$L("DXLS HISTORY")\2," DXLS HISTORY ",!!
D ^YSLRP I YSTOUT!YSUOUT!(YSDFN'>0) D END Q
I '$D(^YSD(627.8,"AD",YSDFN)) W !!?10,"No history on file for ",YSNM D END Q
DEVICE ;
;D RECORD^YSDX0001("DEVICE^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
K IOP S %ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) S ZTRTN="ENPR^YSDX3R1",(ZTSAVE("A"),ZTSAVE("YS*"))="",ZTDESC="YS DXLS PRINT" D ^%ZTLOAD Q
;
ENPR ;Entry to core of print program.
;D RECORD^YSDX0001("ENPR^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
S YSFHDR="DXLS HISTORY LIST" S YSPP=0
PR ;
;D RECORD^YSDX0001("PR^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
U IO D:'$D(YSNOFORM) ENHD^YSFORM S Y1=0,YST=$S(IOST?1"P".E:1,1:0),YSSL=$S(YST:8,1:3),YSLFT=0
W !!,"Prinicipal Diagnosis (DXLS): "
S YSLFT=0
S J=0 F S J=$O(^YSD(627.8,"AH",+YSDFN,J)) QUIT:'J!(YSLFT) D
. S J1=0
. F S J1=$O(^YSD(627.8,"AH",+YSDFN,+J,J1)) QUIT:J1'>0!(YSLFT) D DXLS
D FINISH
I YST=1 D ENFT^YSFORM Q:YSPP
END ;
;D RECORD^YSDX0001("END^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
K A,A1,A2,A3,A4,A5,A6,A7,A8,G,G1,G2,G3,G4,G5,G6,G11,J,J5,J50,K,L,L1
K L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,W,YSMOD,YSDXNN,YSDXN,YSML
K YSDXDT,YSDFN,YSAUTH,YSCD,YSCOND,YSDOB,YSDTM,YSDXS,YSFHDR
K YSFTR,YSLC,YSLFT,YSCON,YSNM,YSPP,YSPS,YSSL,YSSSN,YSSTOP
K YST,YSTM,YSAGE,YSDUZ,YSSEX,YSQT,DIWF,DIWR,DIWL
D ^%ZISC,KILL^%ZTLOAD
QUIT
DXLS ;
;D RECORD^YSDX0001("DXLS^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
N YSDXI
I $Y+YSSL+4>IOSL D CK^YSDX3RU Q:YSTOUT!YSUOUT!YSTOUT ;->
;
; J2=Diagnosis variable pointer Y=Date/time of Diagnosis
N YSDXLSD2,YSDXDATA
S J2=$P(^YSD(627.8,J1,1),U),(Y,YSDXLSD2)=$P(^(0),U,3) D DD^%DT S YSDXLSD=Y
;
; J5=Full global reference to pointed to Diagnosis
S J3=$P(J2,";",2),J4=$P(J2,";"),J5="^"_J3_J4_","_0_")"
;
; J50=0 node of pointed to Diagnosis
S J50=@J5
;
S YSDXCSTX=""
; If DSM table...
I J3["YSD" D
. S YSDXLSN=$G(^YSD(627.7,+J4,"D")) ; Diagnosis name
. S YSDXLS=$P(J50,U) ; ICD Code#
. S YSDXCSTX="(ICD-"_$S($P(J50,U,8)'="":$P(J50,U,8),1:"9")_")"
;
; If ICD9 table...
I J3["ICD9(" D
. S YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",J4,YSDXLSD2,"I")
. S YSDXLSN=$P(YSDXDATA,U,4) ; Diagnosis (free text)
. 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_")"
;
; Do MODIFIERs exist?
I $D(^YSD(627.8,J1,5)) D
. S YSML=$P(^YSD(627.8,J1,5,0),U,3) ; Last IEN for MODIFIERs multiple
. F YSDXI=1:1:YSML D ; Loop thru each multiple entry
. . S M1=$G(^YSD(627.8,J1,5,+YSDXI,0)) ; MODIFIER's 0 node
. . QUIT:M1']"" ;->
. . S YSMOD(+YSDXI)=$P(M1,U,3) ; 'Stands For'
. . K M1
AUTH ;
;D RECORD^YSDX0001("AUTH^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
S J6=+$P(^YSD(627.8,J1,0),U,4) ; Diagnosis by
S J7=$P(^VA(200,+J6,0),U) ; Name of diagnoser
S J8=$P($G(^VA(200,J6,0)),U,9) ; Title pointer
S:J8]"" J8=$P(^DIC(3.1,J8,0),U) ; Title file
S YSAUTH=J7_" "_J8
QUIT:'$D(YSDXLS) ;->
W !!?3,YSDXCSTX,?12,YSDXLS_" "_$E(YSDXLSN,1,56)
I $D(YSMOD) F YSDXI=1:1:YSML I $D(YSMOD(YSDXI)) W:$TR(YSMOD(YSDXI)," ","")]"" !?8,"---"_YSMOD(YSDXI)
;D RECORD^YSDX0001("COMMENT^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
I $D(^YSD(627.8,J1,80,0)) D
. W !?9,"Comments: ",!
. S DIWL=18,DIWR=75,DIWF="W" K ^UTILITY($J,"W")
. S K=0 F S K=$O(^YSD(627.8,J1,80,K)) Q:'K S X=^(K,0) D ^DIWP
I $D(K),K<1 D ^DIWW K ^UTILITY($J,"W")
W !?9,"Entered by: ",YSAUTH,!?9,"Dated ",YSDXLSD,!
QUIT
;
FINISH ;
;D RECORD^YSDX0001("FINISH^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
K J1,J2,J3,J4,J5,J6,YSDXCSTX,YSDXLSN,YSDXLS,YSDXLSD,YSMOD
QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDX3R1 4286 printed Sep 23, 2025@19:50:22 Page 2
YSDX3R1 ;SLC/DJP/LJA - Print of DXLS History for Mental Health Med Rec ;10 May 2013 4:05 PM
+1 ;;5.01;MENTAL HEALTH;**107**;Dec 30, 1994;Build 23
+2 ;
+3 ; Called from the top by MENU option YSDIAGP-DXLS
+4 ;D RECORD^YSDX0001("YSDX3R1^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+5 ;
ENTRY ;
+1 ;D RECORD^YSDX0001("ENTRY^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 WRITE @IOF
WRITE !!?IOM-$LENGTH("DXLS HISTORY")\2," DXLS HISTORY ",!!
+3 DO ^YSLRP
IF YSTOUT!YSUOUT!(YSDFN'>0)
DO END
QUIT
+4 IF '$DATA(^YSD(627.8,"AD",YSDFN))
WRITE !!?10,"No history on file for ",YSNM
DO END
QUIT
DEVICE ;
+1 ;D RECORD^YSDX0001("DEVICE^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 KILL IOP
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="ENPR^YSDX3R1"
SET (ZTSAVE("A"),ZTSAVE("YS*"))=""
SET ZTDESC="YS DXLS PRINT"
DO ^%ZTLOAD
QUIT
+4 ;
ENPR ;Entry to core of print program.
+1 ;D RECORD^YSDX0001("ENPR^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 SET YSFHDR="DXLS HISTORY LIST"
SET YSPP=0
PR ;
+1 ;D RECORD^YSDX0001("PR^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 USE IO
if '$DATA(YSNOFORM)
DO ENHD^YSFORM
SET Y1=0
SET YST=$SELECT(IOST?1"P".E:1,1:0)
SET YSSL=$SELECT(YST:8,1:3)
SET YSLFT=0
+3 WRITE !!,"Prinicipal Diagnosis (DXLS): "
+4 SET YSLFT=0
+5 SET J=0
FOR
SET J=$ORDER(^YSD(627.8,"AH",+YSDFN,J))
if 'J!(YSLFT)
QUIT
Begin DoDot:1
+6 SET J1=0
+7 FOR
SET J1=$ORDER(^YSD(627.8,"AH",+YSDFN,+J,J1))
if J1'>0!(YSLFT)
QUIT
DO DXLS
End DoDot:1
+8 DO FINISH
+9 IF YST=1
DO ENFT^YSFORM
if YSPP
QUIT
END ;
+1 ;D RECORD^YSDX0001("END^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 KILL A,A1,A2,A3,A4,A5,A6,A7,A8,G,G1,G2,G3,G4,G5,G6,G11,J,J5,J50,K,L,L1
+3 KILL L2,L3,L4,L5,L6,L7,L8,L9,L10,L11,W,YSMOD,YSDXNN,YSDXN,YSML
+4 KILL YSDXDT,YSDFN,YSAUTH,YSCD,YSCOND,YSDOB,YSDTM,YSDXS,YSFHDR
+5 KILL YSFTR,YSLC,YSLFT,YSCON,YSNM,YSPP,YSPS,YSSL,YSSSN,YSSTOP
+6 KILL YST,YSTM,YSAGE,YSDUZ,YSSEX,YSQT,DIWF,DIWR,DIWL
+7 DO ^%ZISC
DO KILL^%ZTLOAD
+8 QUIT
DXLS ;
+1 ;D RECORD^YSDX0001("DXLS^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 NEW YSDXI
+3 ;->
IF $Y+YSSL+4>IOSL
DO CK^YSDX3RU
if YSTOUT!YSUOUT!YSTOUT
QUIT
+4 ;
+5 ; J2=Diagnosis variable pointer Y=Date/time of Diagnosis
+6 NEW YSDXLSD2,YSDXDATA
+7 SET J2=$PIECE(^YSD(627.8,J1,1),U)
SET (Y,YSDXLSD2)=$PIECE(^(0),U,3)
DO DD^%DT
SET YSDXLSD=Y
+8 ;
+9 ; J5=Full global reference to pointed to Diagnosis
+10 SET J3=$PIECE(J2,";",2)
SET J4=$PIECE(J2,";")
SET J5="^"_J3_J4_","_0_")"
+11 ;
+12 ; J50=0 node of pointed to Diagnosis
+13 SET J50=@J5
+14 ;
+15 SET YSDXCSTX=""
+16 ; If DSM table...
+17 IF J3["YSD"
Begin DoDot:1
+18 ; Diagnosis name
SET YSDXLSN=$GET(^YSD(627.7,+J4,"D"))
+19 ; ICD Code#
SET YSDXLS=$PIECE(J50,U)
+20 SET YSDXCSTX="(ICD-"_$SELECT($PIECE(J50,U,8)'="":$PIECE(J50,U,8),1:"9")_")"
End DoDot:1
+21 ;
+22 ; If ICD9 table...
+23 IF J3["ICD9("
Begin DoDot:1
+24 SET YSDXDATA=$$ICDDATA^ICDXCODE("DIAG",J4,YSDXLSD2,"I")
+25 ; Diagnosis (free text)
SET YSDXLSN=$PIECE(YSDXDATA,U,4)
+26 ; ICD Code#
SET YSDXLS=$PIECE(YSDXDATA,U,2)
+27 SET YSDXCSTX=$PIECE($PIECE($$SINFO^ICDEX($PIECE(YSDXDATA,U,20)),U,2),"-",2)
+28 SET YSDXCSTX="(ICD-"_YSDXCSTX_")"
End DoDot:1
+29 ;
+30 ; Do MODIFIERs exist?
+31 IF $DATA(^YSD(627.8,J1,5))
Begin DoDot:1
+32 ; Last IEN for MODIFIERs multiple
SET YSML=$PIECE(^YSD(627.8,J1,5,0),U,3)
+33 ; Loop thru each multiple entry
FOR YSDXI=1:1:YSML
Begin DoDot:2
+34 ; MODIFIER's 0 node
SET M1=$GET(^YSD(627.8,J1,5,+YSDXI,0))
+35 ;->
if M1']""
QUIT
+36 ; 'Stands For'
SET YSMOD(+YSDXI)=$PIECE(M1,U,3)
+37 KILL M1
End DoDot:2
End DoDot:1
AUTH ;
+1 ;D RECORD^YSDX0001("AUTH^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 ; Diagnosis by
SET J6=+$PIECE(^YSD(627.8,J1,0),U,4)
+3 ; Name of diagnoser
SET J7=$PIECE(^VA(200,+J6,0),U)
+4 ; Title pointer
SET J8=$PIECE($GET(^VA(200,J6,0)),U,9)
+5 ; Title file
if J8]""
SET J8=$PIECE(^DIC(3.1,J8,0),U)
+6 SET YSAUTH=J7_" "_J8
+7 ;->
if '$DATA(YSDXLS)
QUIT
+8 WRITE !!?3,YSDXCSTX,?12,YSDXLS_" "_$EXTRACT(YSDXLSN,1,56)
+9 IF $DATA(YSMOD)
FOR YSDXI=1:1:YSML
IF $DATA(YSMOD(YSDXI))
if $TRANSLATE(YSMOD(YSDXI)," ","")]""
WRITE !?8,"---"_YSMOD(YSDXI)
+1 ;D RECORD^YSDX0001("COMMENT^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 IF $DATA(^YSD(627.8,J1,80,0))
Begin DoDot:1
+3 WRITE !?9,"Comments: ",!
+4 SET DIWL=18
SET DIWR=75
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
+5 SET K=0
FOR
SET K=$ORDER(^YSD(627.8,J1,80,K))
if 'K
QUIT
SET X=^(K,0)
DO ^DIWP
End DoDot:1
+6 IF $DATA(K)
IF K<1
DO ^DIWW
KILL ^UTILITY($JOB,"W")
+7 WRITE !?9,"Entered by: ",YSAUTH,!?9,"Dated ",YSDXLSD,!
+8 QUIT
+9 ;
FINISH ;
+1 ;D RECORD^YSDX0001("FINISH^YSDX3R1") ;Used for testing. Inactivated in YSDX0001...
+2 KILL J1,J2,J3,J4,J5,J6,YSDXCSTX,YSDXLSN,YSDXLS,YSDXLSD,YSMOD
+3 QUIT
+4 ;
