QAMGRP1 ;HISC/DAD-AUTO LOAD GROUP DATA: ICD DIAGNOSES ;9/3/93 13:14
;;1.0;Clinical Monitoring System;;09/13/1993
F QAQLABEL="AN1","AN2","AN3","AN4","AN5","TR8A","TR8B","TR10","TR11","TR12","CV4" S QAQCHECK=0 D LOOP Q:QAQCHECK=-1
G:QAQCHECK'=-1 ^QAMGRP2
EXIT K X,DIC,DLAYGO,QAMD0,Y,OFFSET,LINE,ST,END,NUM,D0,DIK,DA,LASTD0,TAB,QAQCOUNT,QAQCHECK,QAQLABEL,NUMBER
Q
LOOP ;
S X=$P($T(@QAQLABEL),";;",2) W !!,"Loading: ",X
S QAMD0=+$O(^QA(743.5,"B",$E(X,1,30),0)) I QAMD0 W !!?5,"*** ",X," already exists !! ***",*7 D G:(QAQCHECK=-1)!(QAQCHECK=2) XIT
ASK . W !!?5,"Do you want to check this group's completeness"
. S %=2 D YN^DICN I '% W !!?10,"Please answer Y(es) or N(o)" G ASK
. S QAQCHECK=%
. Q
W !!,"Working",! S (QAQCOUNT,TAB)=0
I QAQCHECK'>0 K DD,DIC,DINUM,DO S DIC="^QA(743.5,",DIC(0)="LM",DIC("DR")=".02////80",DLAYGO=743.5 D FILE^DICN S QAMD0=+Y
F OFFSET=1:1 S LINE=$P($T(@QAQLABEL+OFFSET),";;",2) Q:LINE="" D
. S ST=+LINE,END=$S(LINE["-":+$P(LINE,"-",2),1:ST),NUM=ST-.000001
. F S NUM=$O(^ICD9("BA",NUM)) Q:(NUM'>0)!(NUM>END) D
.. F D0=0:0 S D0=$O(^ICD9("BA",NUM,D0)) Q:D0'>0 D
... S NUMBER=$P($G(^ICD9(D0,0)),"^") Q:NUMBER'>0
... S X=NUMBER_";"_D0
... G:$O(^QA(743.5,QAMD0,"GRP","B",$E(X,1,30),0)) SKIP
... S ^QA(743.5,QAMD0,"GRP",D0,0)=X
... S QAQADICT=743.51,QAQAFLD=.01,DA(1)=QAMD0,DA=D0 D ENSET^QAQAXREF
SKIP ... S LASTD0=D0,QAQCOUNT=QAQCOUNT+1
... W:'TAB ! W ?TAB,NUMBER S TAB=TAB+$S(TAB=70:-70,1:10)
... Q
.. Q
. Q
S ^QA(743.5,QAMD0,"GRP",0)="^743.51A^"_LASTD0_"^"_QAQCOUNT
W !!,QAQCOUNT," ICD-9-CM Diagnosis Codes ",$S(QAQCHECK=1:"checked",1:"loaded"),".",!
XIT Q
;
AN1 ;;AN-1 DIAG GROUP
;;431
;;433.0
;;433.1
;;433.2
;;433.3
;;433.8
;;433.9
;;434.0
;;434.1
;;434.9
;;436
;;668.20
;;668.21
;;668.22
;;997.0
;;
AN2 ;;AN-2 DIAG GROUP
;;736.05
;;736.79
;;781.4
;;782.0
;;
AN3 ;;AN-3 DIAG GROUP
;;410.01
;;410.11
;;410.21
;;410.31
;;410.41
;;410.51
;;410.61
;;410.71
;;410.81
;;410.91
;;
AN4 ;;AN-4 DIAG GROUP
;;427.11
;;427.5
;;668.11
;;668.12
;;669.41
;;669.42
;;997.1
;;
AN5 ;;AN-5 DIAG GROUP
;;669.1
;;799.1
;;995.4
;;998.0
;;
TR8A ;;TR-8A DIAG GROUP (GUNSHOT)
;;879.2-879.5
;;
TR8B ;;TR-8B DIAG GROUP (KNIFE)
;;879.2-879.5
;;
TR10 ;;TR-10 DIAG GROUP
;;821.01
;;821.11
;;
TR11 ;;TR-11 DIAG GROUP
;;852.2
;;852.5
;;868.03
;;868.13
;;860.2
;;860.3
;;860.4
;;860.5
;;901.0
;;902.0
;;423.9
;;560.0
;;560.1
;;
TR12 ;;TR-12 DIAG GROUP-BASIC TRAUMA
;;800.-801.9
;;802.1
;;802.3-802.399999
;;802.5
;;802.7
;;802.9-809.1
;;810.1
;;811.1
;;812.1
;;812.3
;;812.5
;;813.1
;;813.3
;;813.5
;;813.9
;;818-822.1
;;823.1
;;823.3
;;823.9
;;827
;;939.9
;;950-959.9
;;
CV4 ;;CV-4 DIAG GROUP
;;410.0-410.1
;;997.1
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMGRP1 2869 printed Nov 22, 2024@16:52:39 Page 2
QAMGRP1 ;HISC/DAD-AUTO LOAD GROUP DATA: ICD DIAGNOSES ;9/3/93 13:14
+1 ;;1.0;Clinical Monitoring System;;09/13/1993
+2 FOR QAQLABEL="AN1","AN2","AN3","AN4","AN5","TR8A","TR8B","TR10","TR11","TR12","CV4"
SET QAQCHECK=0
DO LOOP
if QAQCHECK=-1
QUIT
+3 if QAQCHECK'=-1
GOTO ^QAMGRP2
EXIT KILL X,DIC,DLAYGO,QAMD0,Y,OFFSET,LINE,ST,END,NUM,D0,DIK,DA,LASTD0,TAB,QAQCOUNT,QAQCHECK,QAQLABEL,NUMBER
+1 QUIT
LOOP ;
+1 SET X=$PIECE($TEXT(@QAQLABEL),";;",2)
WRITE !!,"Loading: ",X
+2 SET QAMD0=+$ORDER(^QA(743.5,"B",$EXTRACT(X,1,30),0))
IF QAMD0
WRITE !!?5,"*** ",X," already exists !! ***",*7
Begin DoDot:1
ASK WRITE !!?5,"Do you want to check this group's completeness"
+1 SET %=2
DO YN^DICN
IF '%
WRITE !!?10,"Please answer Y(es) or N(o)"
GOTO ASK
+2 SET QAQCHECK=%
+3 QUIT
End DoDot:1
if (QAQCHECK=-1)!(QAQCHECK=2)
GOTO XIT
+4 WRITE !!,"Working",!
SET (QAQCOUNT,TAB)=0
+5 IF QAQCHECK'>0
KILL DD,DIC,DINUM,DO
SET DIC="^QA(743.5,"
SET DIC(0)="LM"
SET DIC("DR")=".02////80"
SET DLAYGO=743.5
DO FILE^DICN
SET QAMD0=+Y
+6 FOR OFFSET=1:1
SET LINE=$PIECE($TEXT(@QAQLABEL+OFFSET),";;",2)
if LINE=""
QUIT
Begin DoDot:1
+7 SET ST=+LINE
SET END=$SELECT(LINE["-":+$PIECE(LINE,"-",2),1:ST)
SET NUM=ST-.000001
+8 FOR
SET NUM=$ORDER(^ICD9("BA",NUM))
if (NUM'>0)!(NUM>END)
QUIT
Begin DoDot:2
+9 FOR D0=0:0
SET D0=$ORDER(^ICD9("BA",NUM,D0))
if D0'>0
QUIT
Begin DoDot:3
+10 SET NUMBER=$PIECE($GET(^ICD9(D0,0)),"^")
if NUMBER'>0
QUIT
+11 SET X=NUMBER_";"_D0
+12 if $ORDER(^QA(743.5,QAMD0,"GRP","B",$EXTRACT(X,1,30),0))
GOTO SKIP
+13 SET ^QA(743.5,QAMD0,"GRP",D0,0)=X
+14 SET QAQADICT=743.51
SET QAQAFLD=.01
SET DA(1)=QAMD0
SET DA=D0
DO ENSET^QAQAXREF
SKIP SET LASTD0=D0
SET QAQCOUNT=QAQCOUNT+1
+1 if 'TAB
WRITE !
WRITE ?TAB,NUMBER
SET TAB=TAB+$SELECT(TAB=70:-70,1:10)
+2 QUIT
End DoDot:3
+3 QUIT
End DoDot:2
+4 QUIT
End DoDot:1
+5 SET ^QA(743.5,QAMD0,"GRP",0)="^743.51A^"_LASTD0_"^"_QAQCOUNT
+6 WRITE !!,QAQCOUNT," ICD-9-CM Diagnosis Codes ",$SELECT(QAQCHECK=1:"checked",1:"loaded"),".",!
XIT QUIT
+1 ;
AN1 ;;AN-1 DIAG GROUP
+1 ;;431
+2 ;;433.0
+3 ;;433.1
+4 ;;433.2
+5 ;;433.3
+6 ;;433.8
+7 ;;433.9
+8 ;;434.0
+9 ;;434.1
+10 ;;434.9
+11 ;;436
+12 ;;668.20
+13 ;;668.21
+14 ;;668.22
+15 ;;997.0
+16 ;;
AN2 ;;AN-2 DIAG GROUP
+1 ;;736.05
+2 ;;736.79
+3 ;;781.4
+4 ;;782.0
+5 ;;
AN3 ;;AN-3 DIAG GROUP
+1 ;;410.01
+2 ;;410.11
+3 ;;410.21
+4 ;;410.31
+5 ;;410.41
+6 ;;410.51
+7 ;;410.61
+8 ;;410.71
+9 ;;410.81
+10 ;;410.91
+11 ;;
AN4 ;;AN-4 DIAG GROUP
+1 ;;427.11
+2 ;;427.5
+3 ;;668.11
+4 ;;668.12
+5 ;;669.41
+6 ;;669.42
+7 ;;997.1
+8 ;;
AN5 ;;AN-5 DIAG GROUP
+1 ;;669.1
+2 ;;799.1
+3 ;;995.4
+4 ;;998.0
+5 ;;
TR8A ;;TR-8A DIAG GROUP (GUNSHOT)
+1 ;;879.2-879.5
+2 ;;
TR8B ;;TR-8B DIAG GROUP (KNIFE)
+1 ;;879.2-879.5
+2 ;;
TR10 ;;TR-10 DIAG GROUP
+1 ;;821.01
+2 ;;821.11
+3 ;;
TR11 ;;TR-11 DIAG GROUP
+1 ;;852.2
+2 ;;852.5
+3 ;;868.03
+4 ;;868.13
+5 ;;860.2
+6 ;;860.3
+7 ;;860.4
+8 ;;860.5
+9 ;;901.0
+10 ;;902.0
+11 ;;423.9
+12 ;;560.0
+13 ;;560.1
+14 ;;
TR12 ;;TR-12 DIAG GROUP-BASIC TRAUMA
+1 ;;800.-801.9
+2 ;;802.1
+3 ;;802.3-802.399999
+4 ;;802.5
+5 ;;802.7
+6 ;;802.9-809.1
+7 ;;810.1
+8 ;;811.1
+9 ;;812.1
+10 ;;812.3
+11 ;;812.5
+12 ;;813.1
+13 ;;813.3
+14 ;;813.5
+15 ;;813.9
+16 ;;818-822.1
+17 ;;823.1
+18 ;;823.3
+19 ;;823.9
+20 ;;827
+21 ;;939.9
+22 ;;950-959.9
+23 ;;
CV4 ;;CV-4 DIAG GROUP
+1 ;;410.0-410.1
+2 ;;997.1
+3 ;;
