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