GMRA2PRE.m

GMRA2PRE ;HIRMFO/FPT-Pre-init for GMRA*4*2 ;7/24/96  08:43

 ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996

 ;

 ; This pre-init for patch #2 does the following:

 ; 1) deletes the Soundex cross-reference on File 120.82 Field #.01,

 ; 2) fixes bad data in File 120.86

 ;

 D DEL01,ERR

 Q

 ;

DEL01 ; Delete ^DD(120.8,.01 and ^GMRD(120.8,"SOUND")

 ; This field will be restored in the installation process without

 ; the soundex cross-reference

 S DA=.01,DA(1)=120.82,DIK="^DD(120.82," D ^DIK

 K ^GMRD(120.82,"SOUND"),DA,DIK

 Q

ERR ; Delete patient assessment entry in file 120.86 if second piece is 1

 ; and there are no active entries (i.e., not entered-in-error) in

 ; file 120.8 for the patient.

 ; In File 120.86, fix missing .01 value, delete erroneous 5th piece and

 ; fix 2nd piece.

 S GMRALOOP=0

 F  S GMRALOOP=$O(^GMR(120.86,GMRALOOP)) Q:GMRALOOP'>0  D

 .S GMRANODE=$G(^GMR(120.86,GMRALOOP,0)) ;get zero node

 .S GMRAPRA=$P(GMRANODE,U,2) ;pt reaction assessment

 .I $P(GMRANODE,U,5)]"" S $P(^GMR(120.86,GMRALOOP,0),U,5)="" ;clean out 5th piece

 .I $P(GMRANODE,U,1)="" S $P(^GMR(120.86,GMRALOOP,0),U,1)=GMRALOOP,DA=GMRALOOP,DIK="^GMR(120.86,",DIK(1)=".01" D EN^DIK K DIK(1) ;put in missing name pointer

 .I GMRAPRA=1 I $$NKASCR^GMRANKA(GMRALOOP) S DA=GMRALOOP,DIK="^GMR(120.86," D ^DIK W:$E(IOST)="C" "." Q  ;delete 120.86 entries if assessment=1, but nka

 .I GMRAPRA'=0,GMRAPRA'=1 D  ;look for garbage in pt reaction assessment

 ..S GMRANKA=$$NKASCR^GMRANKA(GMRALOOP) ;pt has reactions (0) or nka (1)

 ..I GMRANKA=1 S DA=GMRALOOP,DIK="^GMR(120.86," D ^DIK W:$E(IOST)="C" "." Q  ;delete 120.86 entry if nka

 ..I GMRANKA=0 S $P(^GMR(120.86,GMRALOOP,0),U,2)=1 ;set pt assessment=1

 ..Q

 .Q 

 K DA,DIK,GMA,GMRALOOP,GMRANKA,GMRANODE,GMRAPRA

 Q

GMRA2PRE  ;HIRMFO/FPT-Pre-init for GMRA*4*2 ;7/24/96  08:43

 +1       ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996

 +2       ;

 +3       ; This pre-init for patch #2 does the following:

 +4       ; 1) deletes the Soundex cross-reference on File 120.82 Field #.01,

 +5       ; 2) fixes bad data in File 120.86

 +6       ;

 +7        DO DEL01

           DO ERR

 +8        QUIT 

 +9       ;

DEL01     ; Delete ^DD(120.8,.01 and ^GMRD(120.8,"SOUND")

 +1       ; This field will be restored in the installation process without

 +2       ; the soundex cross-reference

 +3        SET DA=.01

           SET DA(1)=120.82

           SET DIK="^DD(120.82,"

           DO ^DIK

 +4        KILL ^GMRD(120.82,"SOUND"),DA,DIK

 +5        QUIT 

ERR       ; Delete patient assessment entry in file 120.86 if second piece is 1

 +1       ; and there are no active entries (i.e., not entered-in-error) in

 +2       ; file 120.8 for the patient.

 +3       ; In File 120.86, fix missing .01 value, delete erroneous 5th piece and

 +4       ; fix 2nd piece.

 +5        SET GMRALOOP=0

 +6        FOR 

               SET GMRALOOP=$ORDER(^GMR(120.86,GMRALOOP))

               IF GMRALOOP'>0

                   QUIT 

               Begin DoDot:1

 +7       ;get zero node

                   SET GMRANODE=$GET(^GMR(120.86,GMRALOOP,0))

 +8       ;pt reaction assessment

                   SET GMRAPRA=$PIECE(GMRANODE,U,2)

 +9       ;clean out 5th piece

                   IF $PIECE(GMRANODE,U,5)]""

                       SET $PIECE(^GMR(120.86,GMRALOOP,0),U,5)=""

 +10      ;put in missing name pointer

                   IF $PIECE(GMRANODE,U,1)=""

                       SET $PIECE(^GMR(120.86,GMRALOOP,0),U,1)=GMRALOOP

                       SET DA=GMRALOOP

                       SET DIK="^GMR(120.86,"

                       SET DIK(1)=".01"

                       DO EN^DIK

                       KILL DIK(1)

 +11      ;delete 120.86 entries if assessment=1, but nka

                   IF GMRAPRA=1

                       IF $$NKASCR^GMRANKA(GMRALOOP)

                           SET DA=GMRALOOP

                           SET DIK="^GMR(120.86,"

                           DO ^DIK

                           IF $EXTRACT(IOST)="C"

                               WRITE "."

                           QUIT 

 +12      ;look for garbage in pt reaction assessment

                   IF GMRAPRA'=0

                       IF GMRAPRA'=1

                           Begin DoDot:2

 +13      ;pt has reactions (0) or nka (1)

                               SET GMRANKA=$$NKASCR^GMRANKA(GMRALOOP)

 +14      ;delete 120.86 entry if nka

                               IF GMRANKA=1

                                   SET DA=GMRALOOP

                                   SET DIK="^GMR(120.86,"

                                   DO ^DIK

                                   IF $EXTRACT(IOST)="C"

                                       WRITE "."

                                   QUIT 

 +15      ;set pt assessment=1

                               IF GMRANKA=0

                                   SET $PIECE(^GMR(120.86,GMRALOOP,0),U,2)=1

 +16                           QUIT 

                           End DoDot:2

 +17               QUIT 

               End DoDot:1

 +18       KILL DA,DIK,GMA,GMRALOOP,GMRANKA,GMRANODE,GMRAPRA

 +19       QUIT