- 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 Jan 18, 2025@02:41:08 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