- GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT ENTERED IN ERROR ;9/23/97 09:07
- ;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996
- EN1 ; Entry to ACTIVE LISTING OF PATIENT REACTIONS option
- S GMRAOUT=0
- W ! S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select PATIENT: " D ^DIC K DIC,DLAYGO S DFN=+Y I +Y'>0 S GMRAOUT=1 G EXIT
- EN3 ;Print Active Patient list if patient is known
- D DEM^VADPT S GMRAHEAD(2)=$J($E(VADM(1),1,15),1)_$J(VA("PID"),21)_$J($P(VADM(3),"^",2),24)_$J($S(VADM(4):"("_VADM(4)_")",1:""),5) D KVAR^VADPT K VA
- S GMRAHEAD(1)=$J("ACTIVE ALLERGY/ADVERSE REACTION LISTING",58),(GMRAHEAD(3),GMRAHEAD(6),GMRAHEAD(7))="",$P(GMRAHEAD(6),"-",81)=""
- S GMRAHEAD(4)=$J("OBS/",73),GMRAHEAD(5)=$J("ADVERSE REACTION",17)_$J("VERIFIED",48)_$J("HIST",8)
- S GMRANOW=$$NOW^XLFDT,GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
- S GMRAHEAD(1.5)=$J("Run Date/Time: "_GMRANOW,55)
- I '$D(^GMR(120.86,"B",DFN)) W !!,$C(7),"NO ALLERGY/ADVERSE REACTION DATA EXISTS FOR THIS PATIENT" G EN1
- K GMRAZIS D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
- I $D(IO("Q")) D TASK G EXIT
- EN2 ; Print Active Patient list if patient and device known
- S (GMRAOUT,GMRAPG)=0 D HDR^GMRADSP3
- S GMRALIN=$$REPEAT^XLFSTR("=",32)
- I $P($G(^GMR(120.86,DFN,0)),U,2)'=1 W !," Patient has answered NKA."
- E F GMRAREC=0:0 S GMRAREC=$O(^GMR(120.8,"B",DFN,GMRAREC)) Q:GMRAREC'>0 D EN2A
- S GMRAREAC=0 G DISP
- Q
- EN2A Q:+$G(^GMR(120.8,GMRAREC,"ER")) S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:'$P(GMRATEMP,"^",12)
- S GMRAKIND=$P(GMRATEMP,"^",20)
- S ^TMP($J,"GMRADSP",GMRAKIND,$P(GMRATEMP,"^",2),GMRAREC)=""
- Q
- DISP ;
- S GMRASPAC=53,GMRATONS=""
- S (GMRAALL,GMRAKIND,GMRARECN)=""
- I '$D(^TMP($J,"GMRADSP")) W !,?33,"No Data Found"
- F X=0:0 S GMRAKIND=$O(^TMP($J,"GMRADSP",GMRAKIND)) Q:GMRAKIND=""!GMRAOUT D DISP2
- G EXIT
- DISP2 D:$Y>(IOSL-4) EOP^GMRADSP3 Q:GMRAOUT
- S GMRATYPE=$$OUTTYPE^GMRAUTL(GMRAKIND)
- W !!?3,"TYPE: ",GMRATYPE,!?3,$E(GMRALIN,1,$L(GMRATYPE)+6)
- F X=0:0 S GMRAALL=$O(^TMP($J,"GMRADSP",GMRAKIND,GMRAALL)) Q:GMRAALL=""!(GMRAOUT) F GMRARECN=0:0 S GMRARECN=$O(^TMP($J,"GMRADSP",GMRAKIND,GMRAALL,GMRARECN)) Q:GMRARECN'>0 D REST Q:GMRAOUT
- Q
- REST ;
- D:$Y>(IOSL-4) EOP^GMRADSP3 Q:GMRAOUT
- S GMRATEMP=$G(^GMR(120.8,GMRARECN,0)) W !,GMRAALL,?60,$P("NO^YES","^",1+$P(GMRATEMP,U,16)),?70,$S($P(GMRATEMP,U,6)="h":"HIST",$P(GMRATEMP,U,6)="o":"OBS",1:"")
- I $D(^GMR(120.8,GMRARECN,10,0)) S GMRAFLG=0,GMRAOTH=$O(^GMRD(120.83,"B","OTHER REACTION",0)) F GMRAX=0:0 S GMRAX=$O(^GMR(120.8,GMRARECN,10,GMRAX)) Q:GMRAX'>0 D
- .N GMRALINE,GMRATON,GMRAZ,GMRAFG2
- .S GMRATON=$G(^GMR(120.8,GMRARECN,10,GMRAX,0))
- .S GMRAFG=$O(^GMR(120.8,GMRARECN,10,GMRAX))
- .I +GMRATON'=GMRAOTH S GMRALINE=$E($S($D(^GMRD(120.83,+GMRATON,0)):$P(^(0),U),1:""),1,23)
- .E S GMRALINE=$P(GMRATON,U,2)
- .S GMRAZ=$S($P(GMRATON,U,4)'="":$$FMTE^XLFDT($P(GMRATON,U,4),1),1:"")
- .S:GMRAZ'="" GMRALINE=GMRALINE_" ("_GMRAZ_")"
- .I GMRAFG S GMRALINE=GMRALINE_", "
- .D WRITG
- .Q
- Q
- WRITG ;
- I 'GMRAFLG W !,?5,"Reactions: " S GMRAFLG=1
- I $X+$L(GMRALINE)>GMRASPAC W !,?16
- W GMRALINE
- Q
- EXIT ;Quit and kill
- D CLOSE^GMRAUTL
- K ^TMP($J,"GMRADSP"),X,Y,Z
- D KILL^XUSCLEAN
- Q
- TASK ;
- S ZTDESC="This a print out of the allergies signed off for the patient",ZTRTN="EN2^GMRADSP6",ZTDTH="",ZTIO=ION,ZTSAVE("GMRA*")="",ZTSAVE("DFN")="" D ^%ZTLOAD
- W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
- K ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRADSP6 3422 printed Feb 18, 2025@23:05:20 Page 2
- GMRADSP6 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES NOT ENTERED IN ERROR ;9/23/97 09:07
- +1 ;;4.0;Adverse Reaction Tracking;**8**;Mar 29, 1996
- EN1 ; Entry to ACTIVE LISTING OF PATIENT REACTIONS option
- +1 SET GMRAOUT=0
- +2 WRITE !
- SET DIC="^DPT("
- SET DIC(0)="AEQM"
- SET DIC("A")="Select PATIENT: "
- DO ^DIC
- KILL DIC,DLAYGO
- SET DFN=+Y
- IF +Y'>0
- SET GMRAOUT=1
- GOTO EXIT
- EN3 ;Print Active Patient list if patient is known
- +1 DO DEM^VADPT
- SET GMRAHEAD(2)=$JUSTIFY($EXTRACT(VADM(1),1,15),1)_$JUSTIFY(VA("PID"),21)_$JUSTIFY($PIECE(VADM(3),"^",2),24)_$JUSTIFY($SELECT(VADM(4):"("_VADM(4)_")",1:""),5)
- DO KVAR^VADPT
- KILL VA
- +2 SET GMRAHEAD(1)=$JUSTIFY("ACTIVE ALLERGY/ADVERSE REACTION LISTING",58)
- SET (GMRAHEAD(3),GMRAHEAD(6),GMRAHEAD(7))=""
- SET $PIECE(GMRAHEAD(6),"-",81)=""
- +3 SET GMRAHEAD(4)=$JUSTIFY("OBS/",73)
- SET GMRAHEAD(5)=$JUSTIFY("ADVERSE REACTION",17)_$JUSTIFY("VERIFIED",48)_$JUSTIFY("HIST",8)
- +4 SET GMRANOW=$$NOW^XLFDT
- SET GMRANOW=$$FMTE^XLFDT(GMRANOW,"2P")
- +5 SET GMRAHEAD(1.5)=$JUSTIFY("Run Date/Time: "_GMRANOW,55)
- +6 IF '$DATA(^GMR(120.86,"B",DFN))
- WRITE !!,$CHAR(7),"NO ALLERGY/ADVERSE REACTION DATA EXISTS FOR THIS PATIENT"
- GOTO EN1
- +7 KILL GMRAZIS
- DO DEV^GMRAUTL
- IF POP
- SET GMRAOUT=1
- GOTO EXIT
- +8 IF $DATA(IO("Q"))
- DO TASK
- GOTO EXIT
- EN2 ; Print Active Patient list if patient and device known
- +1 SET (GMRAOUT,GMRAPG)=0
- DO HDR^GMRADSP3
- +2 SET GMRALIN=$$REPEAT^XLFSTR("=",32)
- +3 IF $PIECE($GET(^GMR(120.86,DFN,0)),U,2)'=1
- WRITE !," Patient has answered NKA."
- +4 IF '$TEST
- FOR GMRAREC=0:0
- SET GMRAREC=$ORDER(^GMR(120.8,"B",DFN,GMRAREC))
- if GMRAREC'>0
- QUIT
- DO EN2A
- +5 SET GMRAREAC=0
- GOTO DISP
- +6 QUIT
- EN2A if +$GET(^GMR(120.8,GMRAREC,"ER"))
- QUIT
- SET GMRATEMP=$GET(^GMR(120.8,GMRAREC,0))
- if '$PIECE(GMRATEMP,"^",12)
- QUIT
- +1 SET GMRAKIND=$PIECE(GMRATEMP,"^",20)
- +2 SET ^TMP($JOB,"GMRADSP",GMRAKIND,$PIECE(GMRATEMP,"^",2),GMRAREC)=""
- +3 QUIT
- DISP ;
- +1 SET GMRASPAC=53
- SET GMRATONS=""
- +2 SET (GMRAALL,GMRAKIND,GMRARECN)=""
- +3 IF '$DATA(^TMP($JOB,"GMRADSP"))
- WRITE !,?33,"No Data Found"
- +4 FOR X=0:0
- SET GMRAKIND=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND))
- if GMRAKIND=""!GMRAOUT
- QUIT
- DO DISP2
- +5 GOTO EXIT
- DISP2 if $Y>(IOSL-4)
- DO EOP^GMRADSP3
- if GMRAOUT
- QUIT
- +1 SET GMRATYPE=$$OUTTYPE^GMRAUTL(GMRAKIND)
- +2 WRITE !!?3,"TYPE: ",GMRATYPE,!?3,$EXTRACT(GMRALIN,1,$LENGTH(GMRATYPE)+6)
- +3 FOR X=0:0
- SET GMRAALL=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND,GMRAALL))
- if GMRAALL=""!(GMRAOUT)
- QUIT
- FOR GMRARECN=0:0
- SET GMRARECN=$ORDER(^TMP($JOB,"GMRADSP",GMRAKIND,GMRAALL,GMRARECN))
- if GMRARECN'>0
- QUIT
- DO REST
- if GMRAOUT
- QUIT
- +4 QUIT
- REST ;
- +1 if $Y>(IOSL-4)
- DO EOP^GMRADSP3
- if GMRAOUT
- QUIT
- +2 SET GMRATEMP=$GET(^GMR(120.8,GMRARECN,0))
- WRITE !,GMRAALL,?60,$PIECE("NO^YES","^",1+$PIECE(GMRATEMP,U,16)),?70,$SELECT($PIECE(GMRATEMP,U,6)="h":"HIST",$PIECE(GMRATEMP,U,6)="o":"OBS",1:"")
- +3 IF $DATA(^GMR(120.8,GMRARECN,10,0))
- SET GMRAFLG=0
- SET GMRAOTH=$ORDER(^GMRD(120.83,"B","OTHER REACTION",0))
- FOR GMRAX=0:0
- SET GMRAX=$ORDER(^GMR(120.8,GMRARECN,10,GMRAX))
- if GMRAX'>0
- QUIT
- Begin DoDot:1
- +4 NEW GMRALINE,GMRATON,GMRAZ,GMRAFG2
- +5 SET GMRATON=$GET(^GMR(120.8,GMRARECN,10,GMRAX,0))
- +6 SET GMRAFG=$ORDER(^GMR(120.8,GMRARECN,10,GMRAX))
- +7 IF +GMRATON'=GMRAOTH
- SET GMRALINE=$EXTRACT($SELECT($DATA(^GMRD(120.83,+GMRATON,0)):$PIECE(^(0),U),1:""),1,23)
- +8 IF '$TEST
- SET GMRALINE=$PIECE(GMRATON,U,2)
- +9 SET GMRAZ=$SELECT($PIECE(GMRATON,U,4)'="":$$FMTE^XLFDT($PIECE(GMRATON,U,4),1),1:"")
- +10 if GMRAZ'=""
- SET GMRALINE=GMRALINE_" ("_GMRAZ_")"
- +11 IF GMRAFG
- SET GMRALINE=GMRALINE_", "
- +12 DO WRITG
- +13 QUIT
- End DoDot:1
- +14 QUIT
- WRITG ;
- +1 IF 'GMRAFLG
- WRITE !,?5,"Reactions: "
- SET GMRAFLG=1
- +2 IF $X+$LENGTH(GMRALINE)>GMRASPAC
- WRITE !,?16
- +3 WRITE GMRALINE
- +4 QUIT
- EXIT ;Quit and kill
- +1 DO CLOSE^GMRAUTL
- +2 KILL ^TMP($JOB,"GMRADSP"),X,Y,Z
- +3 DO KILL^XUSCLEAN
- +4 QUIT
- TASK ;
- +1 SET ZTDESC="This a print out of the allergies signed off for the patient"
- SET ZTRTN="EN2^GMRADSP6"
- SET ZTDTH=""
- SET ZTIO=ION
- SET ZTSAVE("GMRA*")=""
- SET ZTSAVE("DFN")=""
- DO ^%ZTLOAD
- +2 WRITE !!,$SELECT($DATA(ZTSK):"Request queued...",1:"Request NOT queued please try later...")
- +3 KILL ZTRTN,ZTDH,ZTSAVE,ZTDTH,ZTSK
- +4 QUIT
