MCRH2 ;WISC/TJK - RHEUMATOLOGY ICD CODE UPDATE FOR QMAN ;7/3/96 09:14
;;2.3;Medicine;**43**;09/13/1996;Build 8
; Reference to $$IMP^ICDEX supported by ICR #5747
; Reference to $$CSI^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR #5747
;
;CALLED FROM DIAGNOSIS FIELD OF RHEUMATOLOGY FILE
SET N ICDSYS,ICDLN,ICD
S ICDSYS=$S($P(^MCAR(701,DA(1),0),U,1)<$$IMP^ICDEX(30):1,1:30),(ICD,ICDLN)=0
F S ICDLN=$O(^MCAR(697.5,X,2,ICDLN)) Q:ICDLN="" D Q:ICD
. S ICD=$G(^MCAR(697.5,X,2,ICDLN,0)) Q:'ICD
. S:$$CSI^ICDEX(80,ICD)'=ICDSYS ICD=0
Q:'ICD
S:'$D(^MCAR(701,DA(1),"ICD",0)) ^(0)="^701.01P^^"
S $P(^MCAR(701,DA(1),"ICD",0),U,3)=DA,$P(^(0),U,4)=$P(^(0),U,4)+1
S ^MCAR(701,DA(1),"ICD",DA,0)=ICD
S ^MCAR(701,DA(1),"ICD","B",ICD,DA)=""
Q
;
KILL N ICD,I,I1
S ICD=$P($G(^MCAR(701,DA(1),"ICD",DA,0)),U) Q:'ICD
K ^MCAR(701,DA(1),"ICD",DA),^MCAR(701,DA(1),"ICD","B",ICD,DA)
S $P(^MCAR(701,DA(1),"ICD",0),U,4)=$P(^MCAR(701,DA(1),"ICD",0),U,4)-1
S I=0 F S I=$O(^MCAR(701,DA(1),"ICD",I)) Q:I'?1N.N S I1=I
S $P(^MCAR(701,DA(1),"ICD",0),U,3)=$S($G(I1):I1,1:"")
Q
PRINT ;PRINTS OUT ICD CODE ON DIAGNOSIS PRINT-CALLED BY PRINT TEMPLATE
N ICD
S ICD=$P($G(^MCAR(701,D0,"ICD",D1,0)),U)
S:ICD'="" ICD=$P($$ICDDX^ICDEX($G(ICD),"",$$CSI^ICDEX(80,$G(ICD)),"I"),U,2)
W ?68,ICD
Q
TEXTHELP ; Display help text from the Data dictionary at the beginging of ever field for RHEUMATOLOGY
Q
N LM,RM,HELP S LM=80,RM=0,HELP=$G(^DD(DJDD,DJAT,3)) D TEXT(HELP,LM,RM)
Q
TEXT(STRING,LM,RM) ;Word warps a string of text and prints it out
;
;STRING = The text to display on the screen
; LM = The left margin
; RM = the right margin
N SPACE,LINE,WORD,TEXT,LENGTH,COUNT,TEMP
S RM=+RM,LM=+LM
I (LM>80)!(LM=0) S LM=80
I LM<RM S RM=TEMP,RM=LM,LM=TEMP
S STRING=STRING_" <*>" ; set up a stopper for word spitter this will allow double spacing between sentences.
I $D(DJCP) X DJCP ; if using the screen handler move to the bottom
F SPACE=1:1 S WORD(SPACE)=$P(STRING," ",SPACE) Q:WORD(SPACE)="<*>"
K WORD(SPACE) S TEXT="",SPACE=SPACE-1
F COUNT=1:1:SPACE D
.S TEMP=TEXT_WORD(COUNT)_" "
.I $L(TEMP)>(LM-RM) W !,?RM,TEXT S TEXT=WORD(COUNT)_" "
.E S TEXT=TEMP
.Q ; end for
W !,?RM,TEXT ; Write the text at the right margin
I $D(DJJ($G(V))),$D(XY) S @$P(DJJ(V),U,2) X XY ;if using the screen handle routine move back to the field location.
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCRH2 2426 printed Nov 22, 2024@17:26:54 Page 2
MCRH2 ;WISC/TJK - RHEUMATOLOGY ICD CODE UPDATE FOR QMAN ;7/3/96 09:14
+1 ;;2.3;Medicine;**43**;09/13/1996;Build 8
+2 ; Reference to $$IMP^ICDEX supported by ICR #5747
+3 ; Reference to $$CSI^ICDEX supported by ICR #5747
+4 ; Reference to $$ICDDX^ICDEX supported by ICR #5747
+5 ;
+6 ;CALLED FROM DIAGNOSIS FIELD OF RHEUMATOLOGY FILE
SET NEW ICDSYS,ICDLN,ICD
+1 SET ICDSYS=$SELECT($PIECE(^MCAR(701,DA(1),0),U,1)<$$IMP^ICDEX(30):1,1:30)
SET (ICD,ICDLN)=0
+2 FOR
SET ICDLN=$ORDER(^MCAR(697.5,X,2,ICDLN))
if ICDLN=""
QUIT
Begin DoDot:1
+3 SET ICD=$GET(^MCAR(697.5,X,2,ICDLN,0))
if 'ICD
QUIT
+4 if $$CSI^ICDEX(80,ICD)'=ICDSYS
SET ICD=0
End DoDot:1
if ICD
QUIT
+5 if 'ICD
QUIT
+6 if '$DATA(^MCAR(701,DA(1),"ICD",0))
SET ^(0)="^701.01P^^"
+7 SET $PIECE(^MCAR(701,DA(1),"ICD",0),U,3)=DA
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
+8 SET ^MCAR(701,DA(1),"ICD",DA,0)=ICD
+9 SET ^MCAR(701,DA(1),"ICD","B",ICD,DA)=""
+10 QUIT
+11 ;
KILL NEW ICD,I,I1
+1 SET ICD=$PIECE($GET(^MCAR(701,DA(1),"ICD",DA,0)),U)
if 'ICD
QUIT
+2 KILL ^MCAR(701,DA(1),"ICD",DA),^MCAR(701,DA(1),"ICD","B",ICD,DA)
+3 SET $PIECE(^MCAR(701,DA(1),"ICD",0),U,4)=$PIECE(^MCAR(701,DA(1),"ICD",0),U,4)-1
+4 SET I=0
FOR
SET I=$ORDER(^MCAR(701,DA(1),"ICD",I))
if I'?1N.N
QUIT
SET I1=I
+5 SET $PIECE(^MCAR(701,DA(1),"ICD",0),U,3)=$SELECT($GET(I1):I1,1:"")
+6 QUIT
PRINT ;PRINTS OUT ICD CODE ON DIAGNOSIS PRINT-CALLED BY PRINT TEMPLATE
+1 NEW ICD
+2 SET ICD=$PIECE($GET(^MCAR(701,D0,"ICD",D1,0)),U)
+3 if ICD'=""
SET ICD=$PIECE($$ICDDX^ICDEX($GET(ICD),"",$$CSI^ICDEX(80,$GET(ICD)),"I"),U,2)
+4 WRITE ?68,ICD
+5 QUIT
TEXTHELP ; Display help text from the Data dictionary at the beginging of ever field for RHEUMATOLOGY
+1 QUIT
+2 NEW LM,RM,HELP
SET LM=80
SET RM=0
SET HELP=$GET(^DD(DJDD,DJAT,3))
DO TEXT(HELP,LM,RM)
+3 QUIT
TEXT(STRING,LM,RM) ;Word warps a string of text and prints it out
+1 ;
+2 ;STRING = The text to display on the screen
+3 ; LM = The left margin
+4 ; RM = the right margin
+5 NEW SPACE,LINE,WORD,TEXT,LENGTH,COUNT,TEMP
+6 SET RM=+RM
SET LM=+LM
+7 IF (LM>80)!(LM=0)
SET LM=80
+8 IF LM<RM
SET RM=TEMP
SET RM=LM
SET LM=TEMP
+9 ; set up a stopper for word spitter this will allow double spacing between sentences.
SET STRING=STRING_" <*>"
+10 ; if using the screen handler move to the bottom
IF $DATA(DJCP)
XECUTE DJCP
+11 FOR SPACE=1:1
SET WORD(SPACE)=$PIECE(STRING," ",SPACE)
if WORD(SPACE)="<*>"
QUIT
+12 KILL WORD(SPACE)
SET TEXT=""
SET SPACE=SPACE-1
+13 FOR COUNT=1:1:SPACE
Begin DoDot:1
+14 SET TEMP=TEXT_WORD(COUNT)_" "
+15 IF $LENGTH(TEMP)>(LM-RM)
WRITE !,?RM,TEXT
SET TEXT=WORD(COUNT)_" "
+16 IF '$TEST
SET TEXT=TEMP
+17 ; end for
QUIT
End DoDot:1
+18 ; Write the text at the right margin
WRITE !,?RM,TEXT
+19 ;if using the screen handle routine move back to the field location.
IF $DATA(DJJ($GET(V)))
IF $DATA(XY)
SET @$PIECE(DJJ(V),U,2)
XECUTE XY
+20 QUIT
