Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BVPRP

BVPRP.m

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