26 lines
871 B
Mathematica
26 lines
871 B
Mathematica
QAOSCNV0 ;HISC/DAD-CONVERT TEXT OF FINDINGS ;5/14/93 08:02
|
|
;;3.0;Occurrence Screen;;09/14/1993
|
|
W !!,"Converting text of findings"
|
|
W !,"---------------------------"
|
|
F QAOSFNUM=1 D LOOP
|
|
K D0,DA,QAOSD0,QAOSFNUM,QAOSOT,QAOSTEXT,QAOSTYPE,QAOSZERO,QAQADICT
|
|
K QAQAFLD,X,Y
|
|
Q
|
|
LOOP ;
|
|
S QAOSD0=$O(^QA(741.6,"B",QAOSFNUM,0))
|
|
S QAOSZERO=$G(^QA(741.6,+QAOSD0,0))
|
|
I (QAOSD0'>0)!(QAOSZERO="") D Q
|
|
. W !!,"*** FINDING NUMBER ",QAOSFNUM," NOT FOUND ***"
|
|
. Q
|
|
S X=$P(QAOSZERO,"^",2),QAQADICT=741.6,QAQAFLD=1,(D0,DA)=QAOSD0
|
|
W !!,"Changing finding number: ",QAOSFNUM,!," From: ",X
|
|
D ENKILL^QAQAXREF
|
|
S QAOSTEXT=$P($T(FIND+QAOSFNUM),";;",2)
|
|
S X=$P(QAOSTEXT,"^",2)
|
|
W !," To: ",X
|
|
S $P(^QA(741.6,QAOSD0,0),"^",2)=X,QAQADICT=741.6,QAQAFLD=1
|
|
S (D0,DA)=QAOSD0 D ENSET^QAQAXREF
|
|
Q
|
|
FIND ;;OLD FINDING TEXT ^ NEW FINDING TEXT
|
|
1 ;;OPTIMAL CARE^UCR - USUAL CUSTOMARY & REASONABLE
|