GMRAMCU0 ;HIRMFO/WAA-ID BAND/CHART MARKING UTILITIES ; 7/30/15
;;4.0;Adverse Reaction Tracking;**49**;Mar 29, 1996;Build 2
;
IDBAND(DFN,DATE,USR) ; This program will mark all the ID Band fields for
; all reactions for a patient
;
; INPUT
; DFN = IEN for a patient in file 2 (Required)
; DATE = Date of marking in File Manager format (optional-
; if undefined or null current date/time will be used).
; USR = User Marking the ID band (optional- if undefined null
; will be used indicating data automatically entered).
;
N GMRADT,GMRAPA,GMRAUSR,GMRASITE
S GMRADT=$G(DATE),GMRAUSR=$G(USR)
I GMRADT="" S GMRADT=$$HTFM^XLFDT($H)
S X=GMRADT,%DT="TS" D ^%DT S GMRADT=Y
D SITE^GMRAUTL S GMRASITE(0)=$G(^GMRD(120.84,+GMRASITE,0)) ;49
I $P(GMRASITE(0),U,5)=0 Q ;49
Q:$G(DFN)<1!(GMRADT<0)!(GMRAUSR'=""&(GMRAUSR'>0))
S GMRAPA=0 F S GMRAPA=$O(^GMR(120.8,"B",DFN,GMRAPA)) Q:GMRAPA<1 D
.Q:$P($G(^GMR(120.8,GMRAPA,0)),U,2)=""!+$G(^GMR(120.8,GMRAPA,"ER"))
.N DA,DD,DO,DIC,DIE,DINUM,DR
.S DIC="^GMR(120.8,"_GMRAPA_",14,",DIC(0)="L",DIC("P")="120.814DA",DLAYGO=120.8,DA(1)=GMRAPA,X=GMRADT D FILE^DICN K DA,DIC
.I Y>0,GMRAUSR'="" D
..S DA(1)=GMRAPA,DA=+Y,DIE="^GMR(120.8,"_DA(1)_",14,",DR="1////"_GMRAUSR
..D ^DIE
..Q
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAMCU0 1315 printed Jan 18, 2025@02:40:47 Page 2
GMRAMCU0 ;HIRMFO/WAA-ID BAND/CHART MARKING UTILITIES ; 7/30/15
+1 ;;4.0;Adverse Reaction Tracking;**49**;Mar 29, 1996;Build 2
+2 ;
IDBAND(DFN,DATE,USR) ; This program will mark all the ID Band fields for
+1 ; all reactions for a patient
+2 ;
+3 ; INPUT
+4 ; DFN = IEN for a patient in file 2 (Required)
+5 ; DATE = Date of marking in File Manager format (optional-
+6 ; if undefined or null current date/time will be used).
+7 ; USR = User Marking the ID band (optional- if undefined null
+8 ; will be used indicating data automatically entered).
+9 ;
+10 NEW GMRADT,GMRAPA,GMRAUSR,GMRASITE
+11 SET GMRADT=$GET(DATE)
SET GMRAUSR=$GET(USR)
+12 IF GMRADT=""
SET GMRADT=$$HTFM^XLFDT($HOROLOG)
+13 SET X=GMRADT
SET %DT="TS"
DO ^%DT
SET GMRADT=Y
+14 ;49
DO SITE^GMRAUTL
SET GMRASITE(0)=$GET(^GMRD(120.84,+GMRASITE,0))
+15 ;49
IF $PIECE(GMRASITE(0),U,5)=0
QUIT
+16 if $GET(DFN)<1!(GMRADT<0)!(GMRAUSR'=""&(GMRAUSR'>0))
QUIT
+17 SET GMRAPA=0
FOR
SET GMRAPA=$ORDER(^GMR(120.8,"B",DFN,GMRAPA))
if GMRAPA<1
QUIT
Begin DoDot:1
+18 if $PIECE($GET(^GMR(120.8,GMRAPA,0)),U,2)=""!+$GET(^GMR(120.8,GMRAPA,"ER"))
QUIT
+19 NEW DA,DD,DO,DIC,DIE,DINUM,DR
+20 SET DIC="^GMR(120.8,"_GMRAPA_",14,"
SET DIC(0)="L"
SET DIC("P")="120.814DA"
SET DLAYGO=120.8
SET DA(1)=GMRAPA
SET X=GMRADT
DO FILE^DICN
KILL DA,DIC
+21 IF Y>0
IF GMRAUSR'=""
Begin DoDot:2
+22 SET DA(1)=GMRAPA
SET DA=+Y
SET DIE="^GMR(120.8,"_DA(1)_",14,"
SET DR="1////"_GMRAUSR
+23 DO ^DIE
+24 QUIT
End DoDot:2
+25 QUIT
End DoDot:1
+26 QUIT
