source: FOIAVistA/trunk/r/NURSING_SERVICE-NUR/NURSEXP.m

Last change on this file was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.9 KB
Line 
1NURSEXP ;HIRMFO/JH,MD,FT-CHECK AND CLEAN EXPERIENCE SUB-FILE IN FILE 210 ;4/4/97 11:14
2 ;;4.0;NURSING SERVICE;;Apr 25, 1997
3TXT ;
4 ;;This option checks the integrity of the Nurs Staff File's Experience
5 ;;sub-file in field 22.5, and makes the following error corrections when
6 ;;necessary:
7 ;;
8 ;;a. Converts pointer values in the Name field to free text values.
9 ;;b. Removes records with no data or cross-references.
10 ;;c. Rebuilds missing Name entries that have a valid 'B' index entry.
11 ;;d. Converts lower case Name entries to upper case.
12 ;;e. Deletes experience entries missing from the NURS Clinical Background File.
13 ;;f. Deletes duplicate cross references.
14 S TXT=$T(TXT) F I=0:1:10 S TXT=$T(TXT+I) W !,$P(TXT,";",3)
15 W ! S DIR(0)="E" D ^DIR Q:$G(DIRUT)
16 ; RE-CROSSREFERENCE SUB FILE 22.5,
17 W @IOF,"Checking Experience sub-file for deficiencies, repairing where necessary.",!
18 S II="210.13AI",DA(1)=0 F S DA(1)=$O(^NURSF(210,DA(1))) Q:DA(1)'>0 S DOUT="" D W "."
19 . S:$P($G(^NURSF(210,DA(1),20,0)),U,2)'="" $P(^(0),U,2)=II
20 . I $G(^NURSF(210,DA(1),20,0))="" S NOD=0,NOD=$O(^NURSF(210,DA(1),20,NOD)),XRF="",XRF=$O(^NURSF(210,DA(1),20,"B",XRF)) D
21 .. I NOD>0 S ^NURSF(210,DA(1),20,0)="^"_II_"^^" D
22 ... I XRF="",$P($G(^NURSF(210,DA(1),20,NOD,0)),U)="" S DIK="^NURSF(210,DA(1),20," D ^DIK K DIK Q
23 ... I XRF="" S ^NURSF(210,DA(1),20,"B",$P(^NURSF(210,DA(1),20,NOD,0),U),NOD)="" Q
24 .. I NOD'>0 D Q:DOUT
25 ... I XRF'="" S NURX=$O(^NURSF(210,DA(1),20,"B",XRF,0)),$P(^NURSF(210,DA(1),20,NURX,0),U)=XRF,^NURSF(210,DA(1),20,0)="^"_II_"^^" Q
26 ... Q
27 .. Q
28 . I $G(^NURSF(210,DA(1),20,0))'="" S NOD=0,NOD=$O(^NURSF(210,DA(1),20,NOD)),XRF="",XRF=$O(^NURSF(210,DA(1),20,"B","")) D Q:DOUT
29 .. I NOD'>0 D Q:DOUT
30 ... I XRF="" K ^NURSF(210,DA(1),20,0) S DOUT=1 Q ;KILL ZERO NODE IF NO ENTRY OR XREF
31 ... S $P(^NURSF(210,DA(1),20,XRF,0),U)=$O(^NURSF(210,DA(1),20,"B",XRF,"")) ;Reset .01 field if null and theres a X'REF
32 ... Q
33 .. I NOD>0 D Q:DOUT
34 ... I XRF="",$P($G(^NURSF(210,DA(1),20,NOD,0)),U)'="" S ^NURSF(210,DA(1),20,"B",$P(^NURSF(210,DA(1),20,NOD,0),U),NOD)="" Q ;If node and no cross-reference, set XRF
35 ... I XRF="",$P(^NURSF(210,DA(1),20,NOD,0),U)="" K ^NURSF(210,DA(1),20,NOD,0) Q
36 ... I XRF'="",$P(^NURSF(210,DA(1),20,NOD,0),U)="" S $P(^NURSF(210,DA(1),20,NOD,0),U)=XRF
37 ... Q
38 .. Q
39 . S DA=$O(^NURSF(210,DA(1),20,"")) Q:DA="" S DA=0 F S DA=$O(^NURSF(210,DA(1),20,DA)) Q:DA'>0 D
40 .. I $E($P(^NURSF(210,DA(1),20,DA,0),U),3)?1.L S NURX=$P(^NURSF(210,DA(1),20,DA,0),U) S $P(^NURSF(210,DA(1),20,DA,0),U)=$$UPPER($P(^NURSF(210,DA(1),20,DA,0),U)) D ;Converte lower to upper
41 ... K ^NURSF(210,DA(1),20,"B",NURX,DA) S ^NURSF(210,DA(1),20,"B",$P(^NURSF(210,DA(1),20,DA,0),U),DA)=""
42 ... Q
43 .. I $P($G(^NURSF(210,DA(1),20,DA,0)),U)?1.N,$P($G(^NURSF(211.5,$P(^NURSF(210,DA(1),20,DA,0),U),0)),U)'="" S NURX=$P(^NURSF(210,DA(1),20,DA,0),U),$P(^NURSF(210,DA(1),20,DA,0),U)=$P(^NURSF(211.5,$P(^(0),U),0),U) D ;Convert Pointer to Free Text
44 ... K ^NURSF(210,DA(1),20,"B",NURX,DA) S ^NURSF(210,DA(1),20,"B",$P(^NURSF(210,DA(1),20,DA,0),U),DA)="" ;Replace pointer cross-reference
45 ... Q
46 .. I $P($G(^NURSF(210,DA(1),20,DA,0)),U)?1.N,$G(^NURSF(211.5,$P(^NURSF(210,DA(1),20,DA,0),U),0))="" S DIK="^NURSF(210,DA(1),20," D ^DIK K DIK S DOUT=1 Q ;Kill Experience field if pointed to nowhere
47 .. I $P($G(^NURSF(210,DA(1),20,DA,0)),U)?1N.E S DIK="^NURSF(210,DA(1),20," D ^DIK K DIK S DOUT=1 Q ;Kill entry if erroneous data in .01 field
48 .. Q
49 . S XX="" F I=0:0 S XX=$O(^NURSF(210,DA(1),20,"B",XX)) Q:XX="" D
50 .. S X=0 F I=0:0 S X=$O(^NURSF(210,DA(1),20,"B",XX,X)) Q:X="" D
51 ... I $P($G(^NURSF(210,DA(1),20,X,0)),U)'=XX K ^NURSF(210,DA(1),20,"B",XX,X) ;KILL EXCESS XREF's
52 ... Q
53 .. Q
54 . S DIK="^NURSF(210,DA(1),20,",DIK(1)=".01^B" D ENALL^DIK K DIK ;Re-Cross-reference .01 field
55 . Q
56 W !,"Done...",!! D CLOSE^NURSUT1,^NURSKILL
57 Q
58UPPER(X) ;Convert lower to upper
59 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Note: See TracBrowser for help on using the repository browser.