GMRAPEH0 ; HIRMFO/WAA,RM - EDIT A/AR DATA FOR A HISTORICAL ALLERGY ; Aug 18, 2023@10:42:25
;;4.0;Adverse Reaction Tracking;**63,68**;Mar 29, 1996;Build 5
;
EN1 ; ENTRY FROM MAIN A/AR EDIT TO EDIT HISTORICAL A/AR
N GMRAREQ,GMRAREQS
S DIE="^GMR(120.8,"
S DA=GMRAPA
S DR="9;8"
D ^DIE
I $D(DTOUT)!$D(DUOUT) G EXIT
K DA,DIE,DR,X,Y
SIG S GMRAREQS=0
D EN1^GMRAPER2(GMRAPA,"120.8",.GMRAOUT,$P(^GMR(120.8,GMRAPA,0),U,9)) G:GMRAOUT EXIT
I $D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) D MECH^GMRAPED0
G EXIT:GMRAOUT
COM S GMRAVCM="O" D ENDING^GMRAPEM1
I $D(DTOUT)!$D(Y) S GMRAOUT=1
I 'GMRAOUT D COMCHECK
I 'GMRAOUT G:GMRAREQ COM
I 'GMRAOUT,$P(GMRAPA(0),"^",6)="h" D CKSIGCOM
I 'GMRAOUT G:GMRAREQS SIG
S GMRAOUT=0
K DA,DR,DIE,DUOUT,DTOUT
Q
COMCHECK ; CHECK TO SEE IF COMMENTS ARE REQUIRED
N DIRUT
S GMRAREQ=($P($G(^GMRD(120.84,+GMRASITE,0)),"^",4)=1) Q:'GMRAREQ
S X=0,X=$O(^GMR(120.8,GMRAPA,26,X)),GMRAREQ=(X'>0)
I GMRAREQ W !!,$C(7),"COMMENTS ARE REQUIRED." D HANGT
I $D(DIRUT) S GMRAOUT=1
Q
CKSIGCOM ; Check to require Historical entry to have
; a sign/symptom entered or a minimum of 4 characters
; in a comment.
N CHARCNT,GMRAX,X
S GMRAREQS=0
I +DA>0 D
. S (X,CHARCNT)=0
. F S X=$O(^GMR(120.8,GMRAPA,26,DA,2,X)) Q:X="" D Q:CHARCNT>3
.. S CHARCNT=CHARCNT+$L($G(^GMR(120.8,GMRAPA,26,DA,2,X,0)))
S GMRAX=$O(^GMR(120.8,GMRAPA,10,0))
S GMRAREQS=$S(((+$G(CHARCNT)<4)&(+GMRAX<1)):1,1:0)
I 'GMRAREQS Q
I DA>0,$D(^GMR(120.8,GMRAPA,26,DA)) D
. ; delete comments less than 4 chars (when no sign/symptom was entered)
. S DIK="^GMR(120.8,"_GMRAPA_",26,"
. S DA(1)=GMRAPA
. D ^DIK
W !!,$C(7),"AT LEAST ONE SIGN/SYMPTOM OR A COMMENT, OF AT LEAST FOUR"
W !,$C(7),"CHARACTERS, MUST BE ENTERED FOR HISTORICAL REACTIONS." D HANGT
I $D(DIRUT) S (GMRAOUT,GMRAOUT1)=1
K DIRUT
Q
HANGT ;Hang for TIMEOUT or press return
N DIR
S DIR(0)="EA",DIR("A")="Press RETURN to continue"
D ^DIR
Q
EXIT ;
K DA,DIK,DR,GMRADT,GMRAR10,GMRAPA1,GMRARAD,GMRARDL,GMRAREC,GMRADATE,GMRARODT,GMRAROT,GMRARPR,GMRAX,GMRAY,GMRAZN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAPEH0 2084 printed Jun 11, 2024@21:24:14 Page 2
GMRAPEH0 ; HIRMFO/WAA,RM - EDIT A/AR DATA FOR A HISTORICAL ALLERGY ; Aug 18, 2023@10:42:25
+1 ;;4.0;Adverse Reaction Tracking;**63,68**;Mar 29, 1996;Build 5
+2 ;
EN1 ; ENTRY FROM MAIN A/AR EDIT TO EDIT HISTORICAL A/AR
+1 NEW GMRAREQ,GMRAREQS
+2 SET DIE="^GMR(120.8,"
+3 SET DA=GMRAPA
+4 SET DR="9;8"
+5 DO ^DIE
+6 IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT
+7 KILL DA,DIE,DR,X,Y
SIG SET GMRAREQS=0
+1 DO EN1^GMRAPER2(GMRAPA,"120.8",.GMRAOUT,$PIECE(^GMR(120.8,GMRAPA,0),U,9))
if GMRAOUT
GOTO EXIT
+2 IF $DATA(^XUSEC("GMRA-ALLERGY VERIFY",DUZ))
DO MECH^GMRAPED0
+3 if GMRAOUT
GOTO EXIT
COM SET GMRAVCM="O"
DO ENDING^GMRAPEM1
+1 IF $DATA(DTOUT)!$DATA(Y)
SET GMRAOUT=1
+2 IF 'GMRAOUT
DO COMCHECK
+3 IF 'GMRAOUT
if GMRAREQ
GOTO COM
+4 IF 'GMRAOUT
IF $PIECE(GMRAPA(0),"^",6)="h"
DO CKSIGCOM
+5 IF 'GMRAOUT
if GMRAREQS
GOTO SIG
+6 SET GMRAOUT=0
+7 KILL DA,DR,DIE,DUOUT,DTOUT
+8 QUIT
COMCHECK ; CHECK TO SEE IF COMMENTS ARE REQUIRED
+1 NEW DIRUT
+2 SET GMRAREQ=($PIECE($GET(^GMRD(120.84,+GMRASITE,0)),"^",4)=1)
if 'GMRAREQ
QUIT
+3 SET X=0
SET X=$ORDER(^GMR(120.8,GMRAPA,26,X))
SET GMRAREQ=(X'>0)
+4 IF GMRAREQ
WRITE !!,$CHAR(7),"COMMENTS ARE REQUIRED."
DO HANGT
+5 IF $DATA(DIRUT)
SET GMRAOUT=1
+6 QUIT
CKSIGCOM ; Check to require Historical entry to have
+1 ; a sign/symptom entered or a minimum of 4 characters
+2 ; in a comment.
+3 NEW CHARCNT,GMRAX,X
+4 SET GMRAREQS=0
+5 IF +DA>0
Begin DoDot:1
+6 SET (X,CHARCNT)=0
+7 FOR
SET X=$ORDER(^GMR(120.8,GMRAPA,26,DA,2,X))
if X=""
QUIT
Begin DoDot:2
+8 SET CHARCNT=CHARCNT+$LENGTH($GET(^GMR(120.8,GMRAPA,26,DA,2,X,0)))
End DoDot:2
if CHARCNT>3
QUIT
End DoDot:1
+9 SET GMRAX=$ORDER(^GMR(120.8,GMRAPA,10,0))
+10 SET GMRAREQS=$SELECT(((+$GET(CHARCNT)<4)&(+GMRAX<1)):1,1:0)
+11 IF 'GMRAREQS
QUIT
+12 IF DA>0
IF $DATA(^GMR(120.8,GMRAPA,26,DA))
Begin DoDot:1
+13 ; delete comments less than 4 chars (when no sign/symptom was entered)
+14 SET DIK="^GMR(120.8,"_GMRAPA_",26,"
+15 SET DA(1)=GMRAPA
+16 DO ^DIK
End DoDot:1
+17 WRITE !!,$CHAR(7),"AT LEAST ONE SIGN/SYMPTOM OR A COMMENT, OF AT LEAST FOUR"
+18 WRITE !,$CHAR(7),"CHARACTERS, MUST BE ENTERED FOR HISTORICAL REACTIONS."
DO HANGT
+19 IF $DATA(DIRUT)
SET (GMRAOUT,GMRAOUT1)=1
+20 KILL DIRUT
+21 QUIT
HANGT ;Hang for TIMEOUT or press return
+1 NEW DIR
+2 SET DIR(0)="EA"
SET DIR("A")="Press RETURN to continue"
+3 DO ^DIR
+4 QUIT
EXIT ;
+1 KILL DA,DIK,DR,GMRADT,GMRAR10,GMRAPA1,GMRARAD,GMRARDL,GMRAREC,GMRADATE,GMRARODT,GMRAROT,GMRARPR,GMRAX,GMRAY,GMRAZN
+2 QUIT
