- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRA2PRE 1783 printed Feb 18, 2025@23:05 Page 2
- 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
