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

VPRDJ08A.m

Go to the documentation of this file. 
  1. VPRDJ08A ;SLC/MKB -- Documents cont ;6/25/12  16:11
  1.  ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ; External References          DBIA#
  1.  ; -------------------          -----
  1.  ; ^DPT                         10035
  1.  ; ^LR                            525
  1.  ; ^RADPT                        2480
  1.  ; ^RARPT                        5605
  1.  ; ^SC                          10040
  1.  ; ^TMP("MDHSP" [MDPS1]          4230
  1.  ; ^VA(200                      10060
  1.  ; %DT                          10003
  1.  ; DIQ                           2056
  1.  ; GMRCGUIB                      2980
  1.  ; LR7OR1,^TMP("LRRR"            2503
  1.  ; MCARUTL3                      3280
  1.  ; PXAPI                         1894
  1.  ; RAO7PC1                  2043,2265
  1.  ; RAO7PC3                       2877
  1.  ;
  1.  ; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
  1.  ;
  1.  ; ------------------------------------------------------------------
  1.  ; documentClass = CLINICAL PROCEDURES
  1.  ; nationalTitle = 4696566^PROCEDURE REPORT
  1.  ;       Service = 4696471^PROCEDURE
  1.  ;          Type = 4696123^REPORT
  1.  ;
  1. CP(DFN,BEG,END,MAX) ; -- Medicine reports
  1.  N VPRN,VPRX,RTN,TIUN,CONS,VPRD,I,DA,X,Y,%DT,DATE,GBL
  1.  S DFN=+$G(DFN) Q:$G(DFN)<1
  1.  D MDPS1^VPRDJ03(DFN,BEG,END,MAX)             ;gets ^TMP("MDHSP",$J)
  1.  S VPRN=0 F  S VPRN=$O(^TMP("MDHSP",$J,VPRN)) Q:VPRN<1  S VPRX=$G(^(VPRN)) D
  1.  . S RTN=$P(VPRX,U,3,4) ;Q:RTN="PRPRO^MDPS4"  ;skip non-CP items
  1.  . S TIUN=+$P(VPRX,U,14)
  1.  . I TIUN D EN1^VPRDJ08(TIUN,38)              ;38=TIU Clinical Document
  1.  . S CONS=+$P(VPRX,U,13) D:CONS DOCLIST^GMRCGUIB(.VPRD,CONS)
  1.  . K DA S I=0 F  S I=$O(VPRD(50,I)) Q:I<1  D
  1.  .. S DA=+VPRD(50,I) Q:DA=TIUN
  1.  .. D EN1^VPRDJ08(DA,38)
  1.  . Q:TIUN!$G(DA)                              ;done [got TIU note(s)]
  1.  . Q:RTN="PR702^MDPS1"                        ;CP, but no TIU note yet
  1.  . Q:RTN="PRPRO^MDPS4"                        ;non-CP procedure
  1.  . ; find ID for pre-TIU report
  1.  . S X=$P(VPRX,U,6),%DT="TXS" D ^%DT Q:Y'>0  S DATE=Y
  1.  . S GBL=+$P(VPRX,U,2)_";"_$$ROOT^VPRDMC(DFN,$P(VPRX,U,11),DATE)
  1.  . I GBL S X=$$CP1(DFN,GBL) D EN1^VPRDJ08(X,"CP")
  1.  K ^TMP("MDHSP",$J),^TMP("VPRTEXT",$J)
  1.  Q
  1.  ;
  1. CP1(DFN,ID) ; -- return report data as TIU string [$$RESOLVE]
  1.  S DFN=+$G(DFN),ID=$G(ID) I DFN<1!'$L(ID) Q ""
  1.  N Y,VPRY,VPRFN,X,NAME,DATE,STS,USER,SIGN,TEXT
  1.  S VPRFN=+$P(ID,"(",2)
  1.  D MEDLKUP^MCARUTL3(.VPRY,VPRFN,+ID)
  1.  I VPRY<1 Q ""  ;error in CP
  1.  S NAME=$P(VPRY,U,9),DATE=$P(VPRY,U,6)
  1.  S X=$$GET1^DIQ(VPRFN,+ID_",",1506)
  1.  S STS=$S($L(X):X,1:"COMPLETED")
  1.  S X=+$$GET1^DIQ(VPRFN,+ID_",",701,"I"),(USER,SIGN)=""
  1.  S:X USER=X_";;"_$P($G(^VA(200,X,0)),U)
  1.  S X=+$$GET1^DIQ(VPRFN,+ID_",",1503,"I")
  1.  S:X SIGN="//"_X_";"_$P($G(^VA(200,X,0)),U)_";"_$$GET1^DIQ(VPRFN,+ID_",",1505,"I")
  1.  ; VST=$$GET1^DIQ(VPRFN,+ID_",",900,"I")
  1.  S Y=ID_U_NAME_U_DATE_U_U_USER_U_U_STS_"^^^2461^"_SIGN
  1.  S:$G(VPRTEXT) TEXT=$$TEXT^VPRDMC(DFN,ID,NAME) ;^TMP("VPRTEXT",$J,ID)
  1.  Q Y
  1.  ;
  1.  ; ------------------------------------------------------------------
  1.  ; documentClass = LR LABORATORY REPORTS
  1.  ; nationalTitle = 4697105^LABORATORY NOTE
  1.  ;       Subject = 4697104^LABORATORY
  1.  ;          Type = 4696120^NOTE
  1.  ;
  1. LR(DFN,BEG,END,MAX) ; -- Lab reports
  1.  N VPRSUB,VPRIDT,VPRITM,VPRTIU,VPRXID,LRDFN,IVDT,VPRN,DA
  1.  S DFN=+$G(DFN) Q:$G(DFN)<1
  1.  S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
  1.  S LRDFN=+$G(^DPT(DFN,"LR")),IVDT=9999999-+$G(^LR(LRDFN,"AU")) ;LR7OB63D error
  1.  K ^TMP("LRRR",$J,DFN) D RR^LR7OR1(DFN,,BEG,END,"AP",,,MAX)
  1.  S VPRSUB="" F  S VPRSUB=$O(^TMP("LRRR",$J,DFN,VPRSUB)) Q:VPRSUB=""  D
  1.  . S VPRIDT=0 F  S VPRIDT=$O(^TMP("LRRR",$J,DFN,VPRSUB,VPRIDT)) Q:VPRIDT<1  I $O(^(VPRIDT,0)) D
  1.  .. S VPRTIU=$S(VPRSUB="AU":$NA(^LR(LRDFN,101)),1:$NA(^LR(LRDFN,VPRSUB,VPRIDT,.05)))
  1.  .. K VPRITM S VPRXID=VPRSUB_";"_VPRIDT
  1.  .. I '$O(@VPRTIU@(0)) S VPRX=$$LR1(DFN,VPRXID) D EN1^VPRDJ08(VPRX,"LR") Q
  1.  .. S VPRN=0 F  S VPRN=$O(@VPRTIU@(VPRN)) Q:VPRN<1  D  ;38=TIU Clin Doc
  1.  ... S DA=+$P($G(@VPRTIU@(VPRN,0)),U,2)
  1.  ... D:DA EN1^VPRDJ08(DA,38)
  1.  K ^TMP("LRRR",$J,DFN),^TMP("VPRTEXT",$J)
  1.  Q
  1.  ;
  1. LR1(DFN,ID) ; -- return report data as TIU string [$$RESOLVE]
  1.  S DFN=+$G(DFN),ID=$G(ID) I DFN<1!'$L(ID) Q ""
  1.  N Y,SUB,IDT,LRDFN,LR0,NAME,LOC,USER,VST,SIGN,TEXT
  1.  K ^TMP("VPRTEXT",$J,ID)
  1.  S SUB=$P(ID,";"),IDT=+$P(ID,";",2),LRDFN=$G(^DPT(DFN,"LR"))
  1.  S LR0=$S(SUB="AU":$G(^LR(LRDFN,"AU")),1:$G(^LR(LRDFN,SUB,IDT,0)))
  1.  S NAME="LR "_$$NAME^VPRDLRA(SUB)_" REPORT"
  1.  S LOC=$P(LR0,U,$S(SUB="AU":5,1:8)) D  ;look-up visit
  1.  . N CDT,SC S CDT=9999999-IDT,SC="",X=0
  1.  . S:$L(LOC) SC=+$O(^SC("B",LOC,0))
  1.  . I CDT,LOC S X=$$GETENC^PXAPI(DFN,CDT,SC)
  1.  . S:X VST=+X
  1.  S X=+$P(LR0,U,$S(SUB="AU":10,1:2)) ;pathologist[author]
  1.  S USER=$S(X:X_";;"_$P($G(^VA(200,X,0)),U),1:""),SIGN=""
  1.  S X=$S(SUB="AU":$P(LR0,U,15,16),1:$P(LR0,U,11)_U_$P(LR0,U,13)) ;released
  1.  S:X SIGN="//"_+$P(X,U,2)_";"_$P($G(^VA(200,+$P(X,U,2),0)),U)_";"_+X
  1.  S Y=ID_U_NAME_U_(9999999-IDT)_U_U_USER_U_LOC_"^COMPLETED^"_$G(VST)_"^^2753^"_SIGN
  1.  S:$G(VPRTEXT) TEXT=$$TEXT^VPRDLRA(DFN,SUB,IDT) ;^TMP("VPRTEXT",$J,ID)
  1.  Q Y
  1.  ;
  1.  ; ------------------------------------------------------------------
  1.  ; nationalTitle = 4695068^RADIOLOGY REPORT
  1.  ;       Subject = 4693357^RADIOLOGY
  1.  ;          Type = 4696123^REPORT
  1.  ;
  1. RA(DFN,BEG,END,MAX) ; -- Radiology reports
  1.  N VPRXID,STS,PSET
  1.  S DFN=+$G(DFN) Q:DFN<1
  1.  S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)_"P"
  1.  K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
  1.  S VPRXID="" F  S VPRXID=$O(^TMP($J,"RAE1",DFN,VPRXID)) Q:VPRXID=""  D
  1.  . S STS=$P($G(^TMP($J,"RAE1",DFN,VPRXID)),U,3),PSET=$G(^(VPRXID,"CPRS"))
  1.  . Q:STS="No Report"!(STS="Deleted")  ;!(STS["Draft")
  1.  . I +PSET=2,$G(PSET(+VPRXID,$P(PSET,U,2))) Q  ;already have report
  1.  . S VPRX=$$RA1(DFN,VPRXID) D EN1^VPRDJ08(VPRX,"RA")
  1.  . I +PSET=2 S PSET(+VPRXID,$P(PSET,U,2))=$P(VPRXID,"-",2) ;parent
  1.  K ^TMP($J,"RAE1"),^TMP("VPRTEXT",$J)
  1.  Q
  1.  ;
  1. RA1(DFN,ID) ; -- return report data as TIU string [$$RESOLVE]
  1.  S DFN=+$G(DFN),ID=$G(ID) I DFN<1!'$L(ID) Q ""
  1.  N EXAM,CASE,PROC,RAE3,RAE1,TEXT,I,X,Y,DATE,LOC,STS,IENS,VST,USER,SIGN
  1.  K RPT,^TMP("VPRTEXT",$J,ID)
  1.  S EXAM=DFN_U_$TR(ID,"-","^") D
  1.  . N DFN D EN3^RAO7PC3(EXAM) ;report
  1.  . D EN3^RAO7PC1(EXAM)       ;add'l values
  1.  S CASE=$O(^TMP($J,"RAE3",DFN,0)),PROC=$O(^(CASE,"")),RAE3=$G(^(PROC))
  1.  S RAE1=$G(^TMP($J,"RAE1",DFN,ID))
  1.  I $G(VPRTEXT) D
  1.  . S TEXT=$NA(^TMP("VPRTEXT",$J,ID))
  1.  . S I=0 F  S I=$O(^TMP($J,"RAE3",DFN,CASE,PROC,I)) Q:I<1  S X=^(I),@TEXT@(I)=X
  1.  S DATE=9999999.9999-(+ID),LOC=$P(RAE1,U,7),STS=$P(RAE3,U)
  1.  S IENS=$P(ID,"-",2)_","_+ID_","_DFN_","
  1.  S VST=$$GET1^DIQ(70.03,IENS,27,"I")
  1.  S X=+$G(^TMP($J,"RAE2",DFN,CASE,PROC,"P")),(USER,SIGN)=""
  1.  S:X USER=X_";;"_$P($G(^VA(200,X,0)),U)
  1.  S X=$G(^TMP($J,"RAE2",DFN,CASE,PROC,"V"))
  1.  S:X SIGN="//"_+X_";"_$P($G(^VA(200,+X,0)),U)_";"_$$GET1^DIQ(74,+$P(RAE1,U,5)_",",7,"I")
  1.  I $D(^TMP($J,"RAE3",DFN,"PRINT_SET")) S PROC=$G(^("ORD")) ;use parent, if printset
  1.  S Y=ID_U_PROC_U_DATE_U_U_USER_U_LOC_U_STS_U_VST_"^^1901^"_SIGN
  1.  K ^TMP($J,"RAE3",DFN),^TMP($J,"RAE2",DFN)
  1.  Q Y