- 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 Mar 13, 2025@21:27:14 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")
