BVPRP ; IHS/ITSC/LJF - RESULTS & PROFILES SUBMENU ;
;;1.0;VIEW PATIENT RECORD;;NOV 17, 2004
; Called by BVP RESULTS protocol
;
EN ;EP -- main entry point for list template BVP OERR
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BVP RESULTS")
D CLEAR^VALM1,EXIT
Q
;
HDR ;EP -- header code
Q
;
INIT ;EP -- init variables and list array
NEW LINE,BVPX
K ^TMP("BVPRP",$J),^TMP("BVPRP1",$J)
S LINE=$$PAD($$SP(6)_$$CONFID^BVPU("Patient"),62)_$$USER^BVPU
S ^TMP("BVPRP",$J,1,0)=LINE
D ENP^XBDIQ1(9000001,DFN,".01;1101.2;1102.98","BVPX(")
S LINE=$$PAD($$SP(5)_"Patient: "_BVPX(.01),34)_" "_$$HRCN^BVPU(DFN)
S ^TMP("BVPRP",$J,2,0)=LINE
S LINE=$$PAD($$SP(9)_"Age: "_BVPX(1102.98),40)_"Sex: "_BVPX(1101.2)
S ^TMP("BVPRP",$J,3,0)=LINE
S LINE=$$SP(6)_"Status: "_$$STATUS^BVPU(DFN)
S ^TMP("BVPRP",$J,4,0)=LINE
S ^TMP("BVPRP",$J,5,0)=""
S VALMCNT=5
Q
;
HELP ;EP -- help code
S X="?" D DISP^XQORM1,MSG^BVPU("",2,0,0)
Q
;
EXIT ;EP -- exit code
K ^TMP("BVPRP",$J),^TMP("BVPRP1",$J)
Q
;
EXPND ;EP -- expand code
Q
;
RESET ;EP -- update display array
I $D(VALMQUIT) S VALMBCK="Q" Q
S DFN=BVPSAV D SETPT^BVPMAIN(DFN) ;make sure patient is still set
D TERM^VALM0 S VALMBCK="R" D HDR Q
;
LABEL ;EP; called by Chart Labels protocol
I '$G(DFN) S DFN=BVPSAV D SETPT^BVPMAIN(DFN)
K ^AGCHLB(DUZ),AGTOT
S ^AGCHLB(DUZ,DFN)="",^AGCHLB(DUZ,"TOT")="",AGTOT=0
D D^AGCHLB,PAUSE^BVPU
Q
;
ERINQ ;EP called by ER Visit Summary protocol
I '$G(DFN) S DFN=BVPSAV D SETPT^BVPMAIN(DFN)
D FULL^VALM1
I '$D(^AMERVSIT("AC",DFN)) W !!,"No Emergency Room visits on file for patient" D PAUSE^BVPU Q
W !! S DIC="^AMERVSIT(",DIC(0)="EQ",D="AC",X=DFN
D IX^DIC K DIC
S DIC="^AMERVSIT(",BY="NUMBER",(FR,TO)=+Y,FLDS="[CAP"
D EN1^DIP,PAUSE^BVPU
Q
;
PATINQ ;EP; called by Patient Inquiry protocol
I '$G(DFN) S DFN=BVPSAV D SETPT^BVPMAIN(DFN)
D EN^BDGPI
Q
;
SURG ;EP; called by Surgical Pathology Report protocol
NEW BVPN,ORVP
D FULL^VALM1,V^LRU,SET^LRAPS3
S DFN=BVPSAV,ORVP=DFN_";DPT(" D OERR^LRAPS3
S PNM=$$GET1^DIQ(2,DFN,.01)
D DT^LRX K DIC,LRTP S LRTP=0,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
S (LRAA(1),X)="SURGICAL PATHOLOGY",LRSS="SP",LRAA=+$O(^LRO(68,"B",X,0))
D R^LRAPCUM,V^LRU,PAUSE^BVPU
Q
;
CYTO ;EP; called by Cytology Report protocol
NEW BVPN,ORVP
D FULL^VALM1,V^LRU,SET^LRAPS3
S DFN=BVPSAV,ORVP=DFN_";DPT(" D OERR^LRAPS3
S PNM=$$GET1^DIQ(2,DFN,.01)
D DT^LRX K DIC,LRTP S LRTP=0,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
S (LRAA(1),X)="CYTOPATHOLOGY",LRSS="CY",LRAA=+$O(^LRO(68,"B",X,0))
D R^LRAPCUM,V^LRU,PAUSE^BVPU
Q
;
BBANK ;EP; called by Blood Back Report protocol
NEW BVPN,ORVP,HRCN
D FULL^VALM1,V^LRU
S DFN=BVPSAV,ORVP=DFN_";DPT(",PNM=$$GET1^DIQ(2,DFN,.01)
D PID^VADPT,SETPT^BVPMAIN(DFN)
D DT^LRX K DIC,LRTP S LRTP=0,LRDPF=+$P(@("^"_$P(ORVP,";",2)_"0)"),"^",2)_"^"_$P(ORVP,";",2) D END^LRDPA Q:LRDFN<1
I '$D(^LR(LRDFN,"BB")) W $C(7),!?3,"No blood bank data for ",PNM D PAUSE^BVPU Q
S LRLLOC="???",(LRSAV,LR("S"))=1
D DEV^LRBLPBR,V^LRU,PAUSE^BVPU
Q
;
RAREQ ;EP; called by Radiology Request Details protocol
NEW ORPK
S ORPK=$G(DFN) Q:'ORPK
I '$D(^RAO(75.1,ORPK,0)) W !?3,"No Radiology Requests on file" D PAUSE^BVPU Q
D ENDIS^RAORD2,PAUSE^BVPU
Q
;
RAPROF ;EP; called by Radiology Profile protocol
NEW ORVP
S (ORVP,RADFN)=+DFN,RAHEAD="**** RAD/NUC MED PATIENT EXAMS ****" S (RAF1,RAREPORT)=1
D ^RAPTLU
I X["^"!'$D(RADUP) D PAUSE^BVPU Q
D OERR^RAORDQ,PAUSE^BVPU
K RAF1,RAREPORT
Q
;
PAD(D,L) ; -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
BVPRP ; IHS/ITSC/LJF - RESULTS & PROFILES SUBMENU ;
+1 ;;1.0;VIEW PATIENT RECORD;;NOV 17, 2004
+2 ; Called by BVP RESULTS protocol
+3 ;
EN ;EP -- main entry point for list template BVP OERR
+1 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+2 DO EN^VALM("BVP RESULTS")
+3 DO CLEAR^VALM1
DO EXIT
+4 QUIT
+5 ;
HDR ;EP -- header code
+1 QUIT
+2 ;
INIT ;EP -- init variables and list array
+1 NEW LINE,BVPX
+2 KILL ^TMP("BVPRP",$JOB),^TMP("BVPRP1",$JOB)
+3 SET LINE=$$PAD($$SP(6)_$$CONFID^BVPU("Patient"),62)_$$USER^BVPU
+4 SET ^TMP("BVPRP",$JOB,1,0)=LINE
+5 DO ENP^XBDIQ1(9000001,DFN,".01;1101.2;1102.98","BVPX(")
+6 SET LINE=$$PAD($$SP(5)_"Patient: "_BVPX(.01),34)_" "_$$HRCN^BVPU(DFN)
+7 SET ^TMP("BVPRP",$JOB,2,0)=LINE
+8 SET LINE=$$PAD($$SP(9)_"Age: "_BVPX(1102.98),40)_"Sex: "_BVPX(1101.2)
+9 SET ^TMP("BVPRP",$JOB,3,0)=LINE
+10 SET LINE=$$SP(6)_"Status: "_$$STATUS^BVPU(DFN)
+11 SET ^TMP("BVPRP",$JOB,4,0)=LINE
+12 SET ^TMP("BVPRP",$JOB,5,0)=""
+13 SET VALMCNT=5
+14 QUIT
+15 ;
HELP ;EP -- help code
+1 SET X="?"
DO DISP^XQORM1
DO MSG^BVPU("",2,0,0)
+2 QUIT
+3 ;
EXIT ;EP -- exit code
+1 KILL ^TMP("BVPRP",$JOB),^TMP("BVPRP1",$JOB)
+2 QUIT
+3 ;
EXPND ;EP -- expand code
+1 QUIT
+2 ;
RESET ;EP -- update display array
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 ;make sure patient is still set
SET DFN=BVPSAV
DO SETPT^BVPMAIN(DFN)
+3 DO TERM^VALM0
SET VALMBCK="R"
DO HDR
QUIT
+4 ;
LABEL ;EP; called by Chart Labels protocol
+1 IF '$GET(DFN)
SET DFN=BVPSAV
DO SETPT^BVPMAIN(DFN)
+2 KILL ^AGCHLB(DUZ),AGTOT
+3 SET ^AGCHLB(DUZ,DFN)=""
SET ^AGCHLB(DUZ,"TOT")=""
SET AGTOT=0
+4 DO D^AGCHLB
DO PAUSE^BVPU
+5 QUIT
+6 ;
ERINQ ;EP called by ER Visit Summary protocol
+1 IF '$GET(DFN)
SET DFN=BVPSAV
DO SETPT^BVPMAIN(DFN)
+2 DO FULL^VALM1
+3 IF '$DATA(^AMERVSIT("AC",DFN))
WRITE !!,"No Emergency Room visits on file for patient"
DO PAUSE^BVPU
QUIT
+4 WRITE !!
SET DIC="^AMERVSIT("
SET DIC(0)="EQ"
SET D="AC"
SET X=DFN
+5 DO IX^DIC
KILL DIC
+6 SET DIC="^AMERVSIT("
SET BY="NUMBER"
SET (FR,TO)=+Y
SET FLDS="[CAP"
+7 DO EN1^DIP
DO PAUSE^BVPU
+8 QUIT
+9 ;
PATINQ ;EP; called by Patient Inquiry protocol
+1 IF '$GET(DFN)
SET DFN=BVPSAV
DO SETPT^BVPMAIN(DFN)
+2 DO EN^BDGPI
+3 QUIT
+4 ;
SURG ;EP; called by Surgical Pathology Report protocol
+1 NEW BVPN,ORVP
+2 DO FULL^VALM1
DO V^LRU
DO SET^LRAPS3
+3 SET DFN=BVPSAV
SET ORVP=DFN_";DPT("
DO OERR^LRAPS3
+4 SET PNM=$$GET1^DIQ(2,DFN,.01)
+5 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
IF LRDFN<1
QUIT
+6 SET (LRAA(1),X)="SURGICAL PATHOLOGY"
SET LRSS="SP"
SET LRAA=+$ORDER(^LRO(68,"B",X,0))
+7 DO R^LRAPCUM
DO V^LRU
DO PAUSE^BVPU
+8 QUIT
+9 ;
CYTO ;EP; called by Cytology Report protocol
+1 NEW BVPN,ORVP
+2 DO FULL^VALM1
DO V^LRU
DO SET^LRAPS3
+3 SET DFN=BVPSAV
SET ORVP=DFN_";DPT("
DO OERR^LRAPS3
+4 SET PNM=$$GET1^DIQ(2,DFN,.01)
+5 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
IF LRDFN<1
QUIT
+6 SET (LRAA(1),X)="CYTOPATHOLOGY"
SET LRSS="CY"
SET LRAA=+$ORDER(^LRO(68,"B",X,0))
+7 DO R^LRAPCUM
DO V^LRU
DO PAUSE^BVPU
+8 QUIT
+9 ;
BBANK ;EP; called by Blood Back Report protocol
+1 NEW BVPN,ORVP,HRCN
+2 DO FULL^VALM1
DO V^LRU
+3 SET DFN=BVPSAV
SET ORVP=DFN_";DPT("
SET PNM=$$GET1^DIQ(2,DFN,.01)
+4 DO PID^VADPT
DO SETPT^BVPMAIN(DFN)
+5 DO DT^LRX
KILL DIC,LRTP
SET LRTP=0
SET LRDPF=+$PIECE(@("^"_$PIECE(ORVP,";",2)_"0)"),"^",2)_"^"_$PIECE(ORVP,";",2)
DO END^LRDPA
IF LRDFN<1
QUIT
+6 IF '$DATA(^LR(LRDFN,"BB"))
WRITE $CHAR(7),!?3,"No blood bank data for ",PNM
DO PAUSE^BVPU
QUIT
+7 SET LRLLOC="???"
SET (LRSAV,LR("S"))=1
+8 DO DEV^LRBLPBR
DO V^LRU
DO PAUSE^BVPU
+9 QUIT
+10 ;
RAREQ ;EP; called by Radiology Request Details protocol
+1 NEW ORPK
+2 SET ORPK=$GET(DFN)
IF 'ORPK
QUIT
+3 IF '$DATA(^RAO(75.1,ORPK,0))
WRITE !?3,"No Radiology Requests on file"
DO PAUSE^BVPU
QUIT
+4 DO ENDIS^RAORD2
DO PAUSE^BVPU
+5 QUIT
+6 ;
RAPROF ;EP; called by Radiology Profile protocol
+1 NEW ORVP
+2 SET (ORVP,RADFN)=+DFN
SET RAHEAD="**** RAD/NUC MED PATIENT EXAMS ****"
SET (RAF1,RAREPORT)=1
+3 DO ^RAPTLU
+4 IF X["^"!'$DATA(RADUP)
DO PAUSE^BVPU
QUIT
+5 DO OERR^RAORDQ
DO PAUSE^BVPU
+6 KILL RAF1,RAREPORT
+7 QUIT
+8 ;
PAD(D,L) ; -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
