Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMRAPEH0

GMRAPEH0.m

Go to the documentation of this file.
GMRAPEH0 ; HIRMFO/WAA,RM - EDIT A/AR DATA FOR A HISTORICAL ALLERGY ;May 11, 2021@12:06:07
 ;;4.0;Adverse Reaction Tracking;**63**;Mar 29, 1996;Build 34
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
 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
 K DIRUT
 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(((+CHARCNT<4)&(+GMRAX<1)):1,1:0)
 I 'GMRAREQS Q
 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