- XTLKTICD ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC- DRIVER ROUTINE FOR ICD LOOKUP UTILITY ;04/06/95 14:19
- ;;7.3;TOOLKIT;;Apr 25, 1995
- ;
- KL K XTLKX,XTLKY,XTLKPF,XTLKUT,DIC,XTLKWD2 Q
- ;
- A D QU^XTLKEFOP()
- I '$D(XTLKY) D KL Q
- W !,"NARRATIVE: " R XTLKX:DTIME I $D(XTLKX) D LKUP^XTLKMGR(+XTLKY,XTLKX)
- D KL
- Q
- ;K XTLKUT S DIC("A")="NARRATIVE: ",DIC=+XTLKY,DIC(0)="AEMQ" D ^DIC,KL Q
- ;
- COMMON W ! F Q=0:0 R "NARRATIVE: ",X:$S($D(DTIME):DTIME,1:300) S:'$T X="^" Q:"^"[X W:X?.E1C.E $C(7)," -- NO CONTROL CHARACTERS ALLOWED!",! D:X'?.E1C.E LOOKUP
- W !
- K XTLKTTYP,Q
- Q
- ;
- ;;;Everything from LOOKUP and under is from old logic. Kept in only
- ;;;because it might be needed or wanted again.
- LOOKUP ;
- ;;;I X="^SYN" S DIE="^XTLKKWLC(",DR=".011:999",DA=$O(^XTLKKWLC("B",XTLKTTYP,"")) D ^DIE W ! Q
- K DIC I +XTLKTTYP=80!(+XTLKTTYP=80.1) S DIC("S")="I $P(^(0),""^"",9)=""""" ; SCREEN OUT INACTIVE CODES
- S:+XTLKTTYP=80 DIC("S")=DIC("S")_",'(+^(0)>300&+^(0)<400&($L($P($P(^(0),""^"",1),""."",2))=3))"
- S:+XTLKTTYP=80.1 DIC("S")=DIC("S")_",'($L($P($P(^(0),""^"",1),""."",2))=3)"
- I X'?1N.E,X'?1"E"1N.E,X'?1"V"1N.E,X'?1"."1N.N G NARR
- CODE ;;;S DIC=$S($E(XTLKTTYP)="D":80,1:80.1),DIC(0)="EQMZ" D ^DIC W ! Q
- NARR ;;;W ! G ICDDX^XTLKKWLD:$E(XTLKTTYP)="D",ICDOP^XTLKKWLD
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTLKTICD 1273 printed Feb 19, 2025@00:07:56 Page 2
- XTLKTICD ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC- DRIVER ROUTINE FOR ICD LOOKUP UTILITY ;04/06/95 14:19
- +1 ;;7.3;TOOLKIT;;Apr 25, 1995
- +2 ;
- KL KILL XTLKX,XTLKY,XTLKPF,XTLKUT,DIC,XTLKWD2
- QUIT
- +1 ;
- A DO QU^XTLKEFOP()
- +1 IF '$DATA(XTLKY)
- DO KL
- QUIT
- +2 WRITE !,"NARRATIVE: "
- READ XTLKX:DTIME
- IF $DATA(XTLKX)
- DO LKUP^XTLKMGR(+XTLKY,XTLKX)
- +3 DO KL
- +4 QUIT
- +5 ;K XTLKUT S DIC("A")="NARRATIVE: ",DIC=+XTLKY,DIC(0)="AEMQ" D ^DIC,KL Q
- +6 ;
- COMMON WRITE !
- FOR Q=0:0
- READ "NARRATIVE: ",X:$SELECT($DATA(DTIME):DTIME,1:300)
- if '$TEST
- SET X="^"
- if "^"[X
- QUIT
- if X?.E1C.E
- WRITE $CHAR(7)," -- NO CONTROL CHARACTERS ALLOWED!",!
- if X'?.E1C.E
- DO LOOKUP
- +1 WRITE !
- +2 KILL XTLKTTYP,Q
- +3 QUIT
- +4 ;
- +5 ;;;Everything from LOOKUP and under is from old logic. Kept in only
- +6 ;;;because it might be needed or wanted again.
- LOOKUP ;
- +1 ;;;I X="^SYN" S DIE="^XTLKKWLC(",DR=".011:999",DA=$O(^XTLKKWLC("B",XTLKTTYP,"")) D ^DIE W ! Q
- +2 ; SCREEN OUT INACTIVE CODES
- KILL DIC
- IF +XTLKTTYP=80!(+XTLKTTYP=80.1)
- SET DIC("S")="I $P(^(0),""^"",9)="""""
- +3 if +XTLKTTYP=80
- SET DIC("S")=DIC("S")_",'(+^(0)>300&+^(0)<400&($L($P($P(^(0),""^"",1),""."",2))=3))"
- +4 if +XTLKTTYP=80.1
- SET DIC("S")=DIC("S")_",'($L($P($P(^(0),""^"",1),""."",2))=3)"
- +5 IF X'?1N.E
- IF X'?1"E"1N.E
- IF X'?1"V"1N.E
- IF X'?1"."1N.N
- GOTO NARR
- CODE ;;;S DIC=$S($E(XTLKTTYP)="D":80,1:80.1),DIC(0)="EQMZ" D ^DIC W ! Q
- NARR ;;;W ! G ICDDX^XTLKKWLD:$E(XTLKTTYP)="D",ICDOP^XTLKKWLD