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.
  1. 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
  1. ;
  1. EN1 ; ENTRY FROM MAIN A/AR EDIT TO EDIT HISTORICAL A/AR
  1. N GMRAREQ,GMRAREQS
  1. S DIE="^GMR(120.8,"
  1. S DA=GMRAPA
  1. S DR="9;8"
  1. D ^DIE
  1. I $D(DTOUT)!$D(DUOUT) G EXIT
  1. K DA,DIE,DR,X,Y
  1. SIG S GMRAREQS=0
  1. D EN1^GMRAPER2(GMRAPA,"120.8",.GMRAOUT,$P(^GMR(120.8,GMRAPA,0),U,9)) G:GMRAOUT EXIT
  1. I $D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) D MECH^GMRAPED0
  1. G EXIT:GMRAOUT
  1. COM S GMRAVCM="O" D ENDING^GMRAPEM1
  1. I $D(DTOUT)!$D(Y) S GMRAOUT=1
  1. I 'GMRAOUT D COMCHECK
  1. I 'GMRAOUT G:GMRAREQ COM
  1. I 'GMRAOUT,$P(GMRAPA(0),"^",6)="h" D CKSIGCOM
  1. I 'GMRAOUT G:GMRAREQS SIG
  1. S GMRAOUT=0
  1. K DA,DR,DIE,DUOUT,DTOUT
  1. Q
  1. COMCHECK ; CHECK TO SEE IF COMMENTS ARE REQUIRED
  1. N DIRUT
  1. S GMRAREQ=($P($G(^GMRD(120.84,+GMRASITE,0)),"^",4)=1) Q:'GMRAREQ
  1. S X=0,X=$O(^GMR(120.8,GMRAPA,26,X)),GMRAREQ=(X'>0)
  1. I GMRAREQ W !!,$C(7),"COMMENTS ARE REQUIRED." D HANGT
  1. I $D(DIRUT) S GMRAOUT=1
  1. Q
  1. CKSIGCOM ; Check to require Historical entry to have
  1. ; a sign/symptom entered or a minimum of 4 characters
  1. ; in a comment.
  1. N CHARCNT,GMRAX,X
  1. S GMRAREQS=0
  1. I +DA>0 D
  1. . S (X,CHARCNT)=0
  1. . F S X=$O(^GMR(120.8,GMRAPA,26,DA,2,X)) Q:X="" D Q:CHARCNT>3
  1. .. S CHARCNT=CHARCNT+$L($G(^GMR(120.8,GMRAPA,26,DA,2,X,0)))
  1. S GMRAX=$O(^GMR(120.8,GMRAPA,10,0))
  1. S GMRAREQS=$S(((+$G(CHARCNT)<4)&(+GMRAX<1)):1,1:0)
  1. I 'GMRAREQS Q
  1. I DA>0,$D(^GMR(120.8,GMRAPA,26,DA)) D
  1. . ; delete comments less than 4 chars (when no sign/symptom was entered)
  1. . S DIK="^GMR(120.8,"_GMRAPA_",26,"
  1. . S DA(1)=GMRAPA
  1. . D ^DIK
  1. W !!,$C(7),"AT LEAST ONE SIGN/SYMPTOM OR A COMMENT, OF AT LEAST FOUR"
  1. W !,$C(7),"CHARACTERS, MUST BE ENTERED FOR HISTORICAL REACTIONS." D HANGT
  1. I $D(DIRUT) S (GMRAOUT,GMRAOUT1)=1
  1. K DIRUT
  1. Q
  1. HANGT ;Hang for TIMEOUT or press return
  1. N DIR
  1. S DIR(0)="EA",DIR("A")="Press RETURN to continue"
  1. D ^DIR
  1. Q
  1. EXIT ;
  1. K DA,DIK,DR,GMRADT,GMRAR10,GMRAPA1,GMRARAD,GMRARDL,GMRAREC,GMRADATE,GMRARODT,GMRAROT,GMRARPR,GMRAX,GMRAY,GMRAZN
  1. Q