GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ;12/04/92
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;
; Reference to $$PROD^XUPROD supported by DBIA 4440
; Reference to $$TESTPAT^VADPT supported by DBIA 3744
;
Q
STPCK() ; This is to check to see if the user wanted to stop the print
S ZTSTOP=0
I $$S^%ZTLOAD D
.S ZTSTOP=1 K ZTREG W !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
.Q
Q ZTSTOP
BR ; This is a online reference card entry point
I '$$TEST^DDBRT D Q
.W $C(7)
.W !,?20,"Your Terminal cannot display this Reference Card."
.W !,?20,"Please contact IRM Service to correct this problem."
.Q
N X
S X=$O(^GMRD(120.87,"B","REFERENCE CARD",0)) Q:X<1
D WP^DDBR(120.87,X,1)
Q
PR ; This is a print utility for the reference card for IRM
W ! K GMRAZIS D DEV^GMRAUTL I POP W !,"PLEASE TRY LATER" S GMRAOUT=1 Q
I $D(IO("Q")) D Q
. S ZTRTN="PR1^GMRAUTL1",(ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
. S ZTDESC="Print reference card" D ^%ZTLOAD
. W !!,$S($D(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
. Q
U IO D PR1 U IO(0)
Q
PR1 ; Print out the card
N GMRAOUT,GMRACD,GMRALN,X
I $E(IOST,1)="C" W @IOF
S GMRACD=$O(^GMRD(120.87,"B","REFERENCE CARD",0))
S (GMRAOUT,GMRALN)=0
LP1 ; Main loop
F S GMRALN=$O(^GMRD(120.87,GMRACD,1,GMRALN)) Q:GMRALN<1 D Q:GMRAOUT
.S X=$G(^GMRD(120.87,GMRACD,1,GMRALN,0))
.W !,X
.I $Y>(IOSL-4) D
..I $E(IOST,1)="C" N DIR,DIRUT,DIROUT,DTOUT,DUOUT S DIR(0)="E" D ^DIR S:$D(DIRUT) GMRAOUT=1 W:'GMRAOUT @IOF Q
..W @IOF
..Q
.Q
D CLOSE^GMRAUTL
Q
PRDTST(GMRADFN) ; GMRA*4*33 - Remove Test Patients from Live Reports
; This function will return 0 if the patient should not print on the report, and 1 if the patient
; should appear on the report. This function will allow all patients to print on the report if the
; report is run in a test environment.
;
I GMRADFN="" Q 0 ;DFN not defined. Should never be the case.
I '$$PROD^XUPROD() Q 1 ;Not a production or legacy environment. Print all patients on report.
I $$TESTPAT^VADPT(GMRADFN) Q 0 ;Production or legacy environment. Test patient. Do not print on report.
Q 1 ;Production or legacy environment. Not a test patient. Print on report.
;
VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT
; This call is a generic call to 1^VADPT
; Input:
; 1 DFN = Patient Internal entry number in the Patient File
; 2 DAT = Date for lookup
;
; Output:
; 3 LOC = Hospital Location
; 4 NAM = Full Patient name
; 5 SEX = Patient SEX
; 6 SSN = Patient SSN
; 7 RB = Patient Room Bed
; 8 PRO = Patient Provider
; 9 PID = Patient ID
;
S DFN=$G(DFN) Q:DFN=""
S VAINDT=$G(DAT) I VAINDT="" K VAINDT
D 1^VADPT
S LOC=$P(VAIN(4),U),NAM=VADM(1),SEX=VADM(5)
S SSN=$P(VADM(2),U,2),RB=VAIN(5),PID=VA("PID")
S PRO=$P(VAIN(2),U,2)
D KVAR^VADPT K VA,VAROOT
Q
DATE(DATE) ; This Ex-Function will date the date from the DATE
; and convert it to the old DD("DD") style format
; it returns the answer in DATE
N Y
S Y=$$FMTE^XLFDT(DATE,1)
S DATE=$P(Y," ")_" "_(+$P($P(Y,",")," ",2))_","_$P(Y," ",3)
Q DATE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRAUTL1 3201 printed Oct 16, 2024@17:41:31 Page 2
GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ;12/04/92
+1 ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
+2 ;
+3 ; Reference to $$PROD^XUPROD supported by DBIA 4440
+4 ; Reference to $$TESTPAT^VADPT supported by DBIA 3744
+5 ;
+6 QUIT
STPCK() ; This is to check to see if the user wanted to stop the print
+1 SET ZTSTOP=0
+2 IF $$S^%ZTLOAD
Begin DoDot:1
+3 SET ZTSTOP=1
KILL ZTREG
WRITE !?10,"*** OUTPUT STOPPED AT USER'S REQUEST ***"
+4 QUIT
End DoDot:1
+5 QUIT ZTSTOP
BR ; This is a online reference card entry point
+1 IF '$$TEST^DDBRT
Begin DoDot:1
+2 WRITE $CHAR(7)
+3 WRITE !,?20,"Your Terminal cannot display this Reference Card."
+4 WRITE !,?20,"Please contact IRM Service to correct this problem."
+5 QUIT
End DoDot:1
QUIT
+6 NEW X
+7 SET X=$ORDER(^GMRD(120.87,"B","REFERENCE CARD",0))
if X<1
QUIT
+8 DO WP^DDBR(120.87,X,1)
+9 QUIT
PR ; This is a print utility for the reference card for IRM
+1 WRITE !
KILL GMRAZIS
DO DEV^GMRAUTL
IF POP
WRITE !,"PLEASE TRY LATER"
SET GMRAOUT=1
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 SET ZTRTN="PR1^GMRAUTL1"
SET (ZTSAVE("GMRAOUT"),ZTSAVE("GMAST"),ZTSAVE("GMAEN"))=""
+4 SET ZTDESC="Print reference card"
DO ^%ZTLOAD
+5 WRITE !!,$SELECT($DATA(ZTSK):"Request queued...",1:"Request NOT queued please try Later.")
+6 QUIT
End DoDot:1
QUIT
+7 USE IO
DO PR1
USE IO(0)
+8 QUIT
PR1 ; Print out the card
+1 NEW GMRAOUT,GMRACD,GMRALN,X
+2 IF $EXTRACT(IOST,1)="C"
WRITE @IOF
+3 SET GMRACD=$ORDER(^GMRD(120.87,"B","REFERENCE CARD",0))
+4 SET (GMRAOUT,GMRALN)=0
LP1 ; Main loop
+1 FOR
SET GMRALN=$ORDER(^GMRD(120.87,GMRACD,1,GMRALN))
if GMRALN<1
QUIT
Begin DoDot:1
+2 SET X=$GET(^GMRD(120.87,GMRACD,1,GMRALN,0))
+3 WRITE !,X
+4 IF $Y>(IOSL-4)
Begin DoDot:2
+5 IF $EXTRACT(IOST,1)="C"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT
SET DIR(0)="E"
DO ^DIR
if $DATA(DIRUT)
SET GMRAOUT=1
if 'GMRAOUT
WRITE @IOF
QUIT
+6 WRITE @IOF
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
if GMRAOUT
QUIT
+9 DO CLOSE^GMRAUTL
+10 QUIT
PRDTST(GMRADFN) ; GMRA*4*33 - Remove Test Patients from Live Reports
+1 ; This function will return 0 if the patient should not print on the report, and 1 if the patient
+2 ; should appear on the report. This function will allow all patients to print on the report if the
+3 ; report is run in a test environment.
+4 ;
+5 ;DFN not defined. Should never be the case.
IF GMRADFN=""
QUIT 0
+6 ;Not a production or legacy environment. Print all patients on report.
IF '$$PROD^XUPROD()
QUIT 1
+7 ;Production or legacy environment. Test patient. Do not print on report.
IF $$TESTPAT^VADPT(GMRADFN)
QUIT 0
+8 ;Production or legacy environment. Not a test patient. Print on report.
QUIT 1
+9 ;
VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT
+1 ; This call is a generic call to 1^VADPT
+2 ; Input:
+3 ; 1 DFN = Patient Internal entry number in the Patient File
+4 ; 2 DAT = Date for lookup
+5 ;
+6 ; Output:
+7 ; 3 LOC = Hospital Location
+8 ; 4 NAM = Full Patient name
+9 ; 5 SEX = Patient SEX
+10 ; 6 SSN = Patient SSN
+11 ; 7 RB = Patient Room Bed
+12 ; 8 PRO = Patient Provider
+13 ; 9 PID = Patient ID
+14 ;
+15 SET DFN=$GET(DFN)
if DFN=""
QUIT
+16 SET VAINDT=$GET(DAT)
IF VAINDT=""
KILL VAINDT
+17 DO 1^VADPT
+18 SET LOC=$PIECE(VAIN(4),U)
SET NAM=VADM(1)
SET SEX=VADM(5)
+19 SET SSN=$PIECE(VADM(2),U,2)
SET RB=VAIN(5)
SET PID=VA("PID")
+20 SET PRO=$PIECE(VAIN(2),U,2)
+21 DO KVAR^VADPT
KILL VA,VAROOT
+22 QUIT
DATE(DATE) ; This Ex-Function will date the date from the DATE
+1 ; and convert it to the old DD("DD") style format
+2 ; it returns the answer in DATE
+3 NEW Y
+4 SET Y=$$FMTE^XLFDT(DATE,1)
+5 SET DATE=$PIECE(Y," ")_" "_(+$PIECE($PIECE(Y,",")," ",2))_","_$PIECE(Y," ",3)
+6 QUIT DATE
