YSDX3UB ;SLC/DJP/LJA-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;09/07/94 13:11
;;5.01;MENTAL HEALTH;;Dec 30, 1994
;D RECORD^YSDX0001("^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
;
MODIF ; Called by routine YSDX3
; Print out modifier questions
;D RECORD^YSDX0001("MODIF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
QUIT:'$D(^YSD(627.7,YSDXDA1,"Q",0)) ;->
W !!,"MODIFIERS: "
S K1=0
F K YSQT S K1=$O(^YSD(627.7,+YSDXDA1,"Q",K1)) Q:'K1 D I $D(YSQT) D DELETE^YSDX3UA QUIT ;->
. S K2=$P(^YSD(627.7,+YSDXDA1,"Q",+K1,0),U)
. D MQUES
. S:K2=36 YSALZ=1
QUIT
MQUES ;
;D RECORD^YSDX0001("MQUES^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
N YSTEST
S YSMODI=$P(^DIC(627.9,+K2,0),U,2)
;
; Set YSQIEN and check if is info only, or query... Exit if info only.
S YSQIEN=+K2
I '$D(^DIC(627.9,+YSQIEN,1)) D QUIT ;->
. S YSX=$P($G(^DIC(627.9,+YSQIEN,0)),U,2)
. W:YSX]"" !!,YSX
;
; Display prompt and get specifier...
D ASKQUAL^YSDX3UC
;
; Various QUITs...
I '$G(YSOK) S YSQT=1 QUIT ;-> YSOK set by ASKQUAL^YSDX3UC
I YSTOUT!YSUOUT S YSQT=1 QUIT ;->
I '$D(^DIC(627.9,+YSQIEN,1,"B")) S YSQT=1 QUIT ;->
I '$D(YSQCH) QUIT ;-> Do NOT set YSQT. User just did not select anything...
;
D MSET ; Store selected modifier(s) in 627.8...
;
QUIT
;
DQP(YSPEC) ; Display Qualifier Prompt (Specifier)
; Note: Cursor should be at beginning of line when DQP call made.
QUIT:$G(YSPEC)']"" ;->
N YSX,YSY,YSZ
;
; Change =s to .s
S YSZ("=")=". "
S YSZ(" - :")=":"
S YSPEC=$$REPLACE^XLFSTR(YSPEC,.YSZ)
;
; Itemized specifiers text...
I YSPEC[":" D QUIT ;->
. D DQP1($P(YSPEC,":")) W ":" ;Print prompt
. S YSPEC=$P(YSPEC,":",2,99) ;Cut off prompt
. F QUIT:$E(YSPEC)'=" " S YSPEC=$E(YSPEC,2,999) ;Trim leading spaces
.
. W:$X>9 ! W ?10
. F YSX=1:1:$L(YSPEC,";") S YSY=$P(YSPEC,";",+YSX) I YSY]"" D
. . F QUIT:$E(YSY)'=" " S YSY=$E(YSY,2,999) ;Trim leading spaces
. . I $L(YSY)<(IOM-13) W YSY,!,?10 QUIT ;->
. . F YSI=(IOM-13):-1:1 QUIT:$E(YSY,YSI)=" "
. . S YSI=$S(YSI:YSI,1:IOM-13)
. . W $E(YSY,1,YSI),!,?13,$E(YSY,YSI+1,999)
. . W !,?10
;
; Non-itemized specifiers text...
I $E(YSPEC,1,8)'[":" D DQP1(YSPEC)
QUIT
;
DQP1(YSPEC) ;Print prompt with proper wrapping...
; After call, cursor is left at end of last line...
QUIT:$G(YSPEC)']"" ;->
W:$X>1 !
N YSX
F D QUIT:YSPEC']"" ;->
. I $L(YSPEC)<(IOM) W YSPEC S YSPEC="" QUIT ;->
. F YSX=IOM:-1:1 QUIT:$E(YSPEC,YSX)=" "
. S YSX=$S(YSX:YSX,1:$L(YSPEC))
. W $E(YSPEC,1,+YSX)
. S YSPEC=$E(YSPEC,+YSX+1,999)
. W:YSPEC]"" ! ;More to print, so have to insert a line feed...
QUIT
;
YN ;
;D RECORD^YSDX0001("YN^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
S K3=$TR(K3,"yn","YN")
I K3["?" D QUIT ;->
. W !!,"Diagnosis may be modified. Answer ""YES"" or ""NO""."
. S K5=1
I "Y"'[K3&("N"'[K3) W "??" S K5=1 QUIT ;->
I "Y"[K3 S K3=1
I "Y"'[K3 S K3=2
QUIT
;
NUM ;
;D RECORD^YSDX0001("NUM^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
I K3="?" D QUIT ;->
. W !!,"Diagnosis may be modified. Answer with corresponding numeric."
. S K5=1
I K3="??"&(K2=1) S XQH="YS-GEN MODIFIER" D EN^XQH S K5=1 QUIT ;->
I K3'?1.N W "??" S K5=1 QUIT ;->
S N=$P(^DIC(627.9,+K2,1,0),U,3)
I K3<1!(K3>N) W !!,"Answer with corresponding numeric." S K5=1 QUIT ;->
QUIT
;
MSET ;
;D RECORD^YSDX0001("MSET^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
; YSQCH( -- req
QUIT:'$D(YSQCH) ;->
N DA,DIE,DR,YSLP,YSQIEN,YSQSFOR,YSQUSEL
L +^YSD(627.8,YSDA)
S DIE="^YSD(627.8,",DA=YSDA
S YSLP="YSQCH"
F S YSLP=$Q(@YSLP) QUIT:YSLP'["YSQCH(" D
. S YSQIEN=+$P(YSLP,"(",2),YSQUSEL=$P($P(YSLP,",",2),")")
. QUIT:YSQIEN'>0!(YSQUSEL']"") ;->
. S X=@YSLP,YSQSFOR=$S($TR(X," ","")="":"",1:X)
. S DR="50///"_+YSQIEN
. S DR(2,627.82)="1///"_$TR(YSQUSEL,"""","")
. I YSQSFOR]"" S DR(2,627.82)=DR(2,627.82)_";2///"_YSQSFOR
. D ^DIE
L -^YSD(627.8,YSDA)
QUIT
;
GAF ; Called by routine YSDX3B, YSDX3RUA
; Calculates the highest GAF for the past year. YSGAF(X) stores scale^DA.
;D RECORD^YSDX0001("GAF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
K G5 S (G,G2)=0
F S G=$O(^YSD(627.8,"AX5",YSDFN,G)) Q:'G D
. S G1=0
. F S G1=$O(^YSD(627.8,"AX5",YSDFN,G,G1)) Q:'G1 D GAF1
I $D(YSGAF) S G5=0 D
. F I=1:1:G2 S G6=$P(YSGAF(I),U) I G6>G5 S G5=G6,G10=$P(YSGAF(I),U,2)
. S Y=$P(^YSD(627.8,G10,0),U,3) D DD^%DT S G11=$P(Y,"@")
QUIT
;
GAF1 ;
;D RECORD^YSDX0001("GAF1^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
S %DT="",X="T" D ^%DT S G4=(Y-$P($P(^YSD(627.8,G1,0),U,3),"."))
QUIT:G4>10000 ;->
S G2=G2+1,YSGAF(G2)=$P(^YSD(627.8,G1,60),U,3)_"^"_G1
QUIT
;
EOR ;YSDX3UB-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;9/18/91 15:39
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYSDX3UB 4979 printed Oct 16, 2024@18:15:06 Page 2
YSDX3UB ;SLC/DJP/LJA-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;09/07/94 13:11
+1 ;;5.01;MENTAL HEALTH;;Dec 30, 1994
+2 ;D RECORD^YSDX0001("^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+3 ;
MODIF ; Called by routine YSDX3
+1 ; Print out modifier questions
+2 ;D RECORD^YSDX0001("MODIF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+3 ;->
if '$DATA(^YSD(627.7,YSDXDA1,"Q",0))
QUIT
+4 WRITE !!,"MODIFIERS: "
+5 SET K1=0
+6 ;->
FOR
KILL YSQT
SET K1=$ORDER(^YSD(627.7,+YSDXDA1,"Q",K1))
if 'K1
QUIT
Begin DoDot:1
+7 SET K2=$PIECE(^YSD(627.7,+YSDXDA1,"Q",+K1,0),U)
+8 DO MQUES
+9 if K2=36
SET YSALZ=1
End DoDot:1
IF $DATA(YSQT)
DO DELETE^YSDX3UA
QUIT
+10 QUIT
MQUES ;
+1 ;D RECORD^YSDX0001("MQUES^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+2 NEW YSTEST
+3 SET YSMODI=$PIECE(^DIC(627.9,+K2,0),U,2)
+4 ;
+5 ; Set YSQIEN and check if is info only, or query... Exit if info only.
+6 SET YSQIEN=+K2
+7 ;->
IF '$DATA(^DIC(627.9,+YSQIEN,1))
Begin DoDot:1
+8 SET YSX=$PIECE($GET(^DIC(627.9,+YSQIEN,0)),U,2)
+9 if YSX]""
WRITE !!,YSX
End DoDot:1
QUIT
+10 ;
+11 ; Display prompt and get specifier...
+12 DO ASKQUAL^YSDX3UC
+13 ;
+14 ; Various QUITs...
+15 ;-> YSOK set by ASKQUAL^YSDX3UC
IF '$GET(YSOK)
SET YSQT=1
QUIT
+16 ;->
IF YSTOUT!YSUOUT
SET YSQT=1
QUIT
+17 ;->
IF '$DATA(^DIC(627.9,+YSQIEN,1,"B"))
SET YSQT=1
QUIT
+18 ;-> Do NOT set YSQT. User just did not select anything...
IF '$DATA(YSQCH)
QUIT
+19 ;
+20 ; Store selected modifier(s) in 627.8...
DO MSET
+21 ;
+22 QUIT
+23 ;
DQP(YSPEC) ; Display Qualifier Prompt (Specifier)
+1 ; Note: Cursor should be at beginning of line when DQP call made.
+2 ;->
if $GET(YSPEC)']""
QUIT
+3 NEW YSX,YSY,YSZ
+4 ;
+5 ; Change =s to .s
+6 SET YSZ("=")=". "
+7 SET YSZ(" - :")=":"
+8 SET YSPEC=$$REPLACE^XLFSTR(YSPEC,.YSZ)
+9 ;
+10 ; Itemized specifiers text...
+11 ;->
IF YSPEC[":"
Begin DoDot:1
+12 ;Print prompt
DO DQP1($PIECE(YSPEC,":"))
WRITE ":"
+13 ;Cut off prompt
SET YSPEC=$PIECE(YSPEC,":",2,99)
+14 ;Trim leading spaces
FOR
if $EXTRACT(YSPEC)'=" "
QUIT
SET YSPEC=$EXTRACT(YSPEC,2,999)
+15 +16 if $X>9
WRITE !
WRITE ?10
+17 FOR YSX=1:1:$LENGTH(YSPEC,";")
SET YSY=$PIECE(YSPEC,";",+YSX)
IF YSY]""
Begin DoDot:2
+18 ;Trim leading spaces
FOR
if $EXTRACT(YSY)'=" "
QUIT
SET YSY=$EXTRACT(YSY,2,999)
+19 ;->
IF $LENGTH(YSY)<(IOM-13)
WRITE YSY,!,?10
QUIT
+20 FOR YSI=(IOM-13):-1:1
if $EXTRACT(YSY,YSI)=" "
QUIT
+21 SET YSI=$SELECT(YSI:YSI,1:IOM-13)
+22 WRITE $EXTRACT(YSY,1,YSI),!,?13,$EXTRACT(YSY,YSI+1,999)
+23 WRITE !,?10
End DoDot:2
End DoDot:1
QUIT
+24 ;
+25 ; Non-itemized specifiers text...
+26 IF $EXTRACT(YSPEC,1,8)'[":"
DO DQP1(YSPEC)
+27 QUIT
+28 ;
DQP1(YSPEC) ;Print prompt with proper wrapping...
+1 ; After call, cursor is left at end of last line...
+2 ;->
if $GET(YSPEC)']""
QUIT
+3 if $X>1
WRITE !
+4 NEW YSX
+5 ;->
FOR
Begin DoDot:1
+6 ;->
IF $LENGTH(YSPEC)<(IOM)
WRITE YSPEC
SET YSPEC=""
QUIT
+7 FOR YSX=IOM:-1:1
if $EXTRACT(YSPEC,YSX)=" "
QUIT
+8 SET YSX=$SELECT(YSX:YSX,1:$LENGTH(YSPEC))
+9 WRITE $EXTRACT(YSPEC,1,+YSX)
+10 SET YSPEC=$EXTRACT(YSPEC,+YSX+1,999)
+11 ;More to print, so have to insert a line feed...
if YSPEC]""
WRITE !
End DoDot:1
if YSPEC']""
QUIT
+12 QUIT
+13 ;
YN ;
+1 ;D RECORD^YSDX0001("YN^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+2 SET K3=$TRANSLATE(K3,"yn","YN")
+3 ;->
IF K3["?"
Begin DoDot:1
+4 WRITE !!,"Diagnosis may be modified. Answer ""YES"" or ""NO""."
+5 SET K5=1
End DoDot:1
QUIT
+6 ;->
IF "Y"'[K3&("N"'[K3)
WRITE "??"
SET K5=1
QUIT
+7 IF "Y"[K3
SET K3=1
+8 IF "Y"'[K3
SET K3=2
+9 QUIT
+10 ;
NUM ;
+1 ;D RECORD^YSDX0001("NUM^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+2 ;->
IF K3="?"
Begin DoDot:1
+3 WRITE !!,"Diagnosis may be modified. Answer with corresponding numeric."
+4 SET K5=1
End DoDot:1
QUIT
+5 ;->
IF K3="??"&(K2=1)
SET XQH="YS-GEN MODIFIER"
DO EN^XQH
SET K5=1
QUIT
+6 ;->
IF K3'?1.N
WRITE "??"
SET K5=1
QUIT
+7 SET N=$PIECE(^DIC(627.9,+K2,1,0),U,3)
+8 ;->
IF K3<1!(K3>N)
WRITE !!,"Answer with corresponding numeric."
SET K5=1
QUIT
+9 QUIT
+10 ;
MSET ;
+1 ;D RECORD^YSDX0001("MSET^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+2 ; YSQCH( -- req
+3 ;->
if '$DATA(YSQCH)
QUIT
+4 NEW DA,DIE,DR,YSLP,YSQIEN,YSQSFOR,YSQUSEL
+5 LOCK +^YSD(627.8,YSDA)
+6 SET DIE="^YSD(627.8,"
SET DA=YSDA
+7 SET YSLP="YSQCH"
+8 FOR
SET YSLP=$QUERY(@YSLP)
if YSLP'["YSQCH("
QUIT
Begin DoDot:1
+9 SET YSQIEN=+$PIECE(YSLP,"(",2)
SET YSQUSEL=$PIECE($PIECE(YSLP,",",2),")")
+10 ;->
if YSQIEN'>0!(YSQUSEL']"")
QUIT
+11 SET X=@YSLP
SET YSQSFOR=$SELECT($TRANSLATE(X," ","")="":"",1:X)
+12 SET DR="50///"_+YSQIEN
+13 SET DR(2,627.82)="1///"_$TRANSLATE(YSQUSEL,"""","")
+14 IF YSQSFOR]""
SET DR(2,627.82)=DR(2,627.82)_";2///"_YSQSFOR
+15 DO ^DIE
End DoDot:1
+16 LOCK -^YSD(627.8,YSDA)
+17 QUIT
+18 ;
GAF ; Called by routine YSDX3B, YSDX3RUA
+1 ; Calculates the highest GAF for the past year. YSGAF(X) stores scale^DA.
+2 ;D RECORD^YSDX0001("GAF^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+3 KILL G5
SET (G,G2)=0
+4 FOR
SET G=$ORDER(^YSD(627.8,"AX5",YSDFN,G))
if 'G
QUIT
Begin DoDot:1
+5 SET G1=0
+6 FOR
SET G1=$ORDER(^YSD(627.8,"AX5",YSDFN,G,G1))
if 'G1
QUIT
DO GAF1
End DoDot:1
+7 IF $DATA(YSGAF)
SET G5=0
Begin DoDot:1
+8 FOR I=1:1:G2
SET G6=$PIECE(YSGAF(I),U)
IF G6>G5
SET G5=G6
SET G10=$PIECE(YSGAF(I),U,2)
+9 SET Y=$PIECE(^YSD(627.8,G10,0),U,3)
DO DD^%DT
SET G11=$PIECE(Y,"@")
End DoDot:1
+10 QUIT
+11 ;
GAF1 ;
+1 ;D RECORD^YSDX0001("GAF1^YSDX3UB") ;Used for testing. Inactivated in YSDX0001...
+2 SET %DT=""
SET X="T"
DO ^%DT
SET G4=(Y-$PIECE($PIECE(^YSD(627.8,G1,0),U,3),"."))
+3 ;->
if G4>10000
QUIT
+4 SET G2=G2+1
SET YSGAF(G2)=$PIECE(^YSD(627.8,G1,60),U,3)_"^"_G1
+5 QUIT
+6 ;
EOR ;YSDX3UB-Continuation of Utilities for Diagnosis Entry in the MH Medical Record ;9/18/91 15:39
