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

VBECRPCW.m

Go to the documentation of this file.
  1. VBECRPCW ; HOIFO/BNT-VBECS Workload Code Lookup RPC ;18 May 2004
  1. ;;2.0;VBEC;;Jun 05, 2015;Build 4
  1. ;
  1. ; Note: This routine supports data exchange with an FDA registered
  1. ; medical device. As such, it may not be changed in any way without
  1. ; prior written approval from the medical device manufacturer.
  1. ;
  1. ; Integration Agreements:
  1. ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
  1. ; Reference to ^LAM suppored by IA #4779
  1. ;
  1. QUIT
  1. ;
  1. WKLD(RESULTS) ;
  1. ; Get Workload data for use case 29
  1. ;
  1. S VBECCNT=0
  1. S RESULTS=$NA(^TMP("VBECWKLD",$J))
  1. K @RESULTS
  1. N WKLD0,CNT,X,Y,LRSEC,PROC,COST,CPT
  1. S (CNT,X)=0
  1. D BEGROOT^VBECRPC("Workload")
  1. F S X=$O(^LAM(X)) Q:'+X D
  1. . S WKLD0=^LAM(X,0)
  1. . S WGHT=$P(WKLD0,"^",3)
  1. . S:'WGHT WGHT=1
  1. . ; Round weight multiplier decimal value to nearest integer.
  1. . I WGHT["." D
  1. . . S X1=$P(WGHT,"."),X2=$P(WGHT,".",2)
  1. . . S WGHT=$S(X2>4:X1+1,1:X1)
  1. . ; Set weight multiplier to 1 if undefined or 0.
  1. . S WGHT=$S(WGHT']"":1,WGHT=0:1,1:WGHT)
  1. . S LRSEC=$P(WKLD0,"^",15) Q:LRSEC=""
  1. . Q:'$D(^LAB(64.21,"B","Blood Bank",LRSEC))
  1. . D BEGROOT^VBECRPC("Code")
  1. . D ADD^VBECRPC("<LMIP>"_$$CHARCHK^XOBVLIB($P(WKLD0,"^",2))_"</LMIP>")
  1. . D ADD^VBECRPC("<Procedure>"_$$CHARCHK^XOBVLIB($P(WKLD0,"^"))_"</Procedure>")
  1. . D ADD^VBECRPC("<Cost>"_$$CHARCHK^XOBVLIB($P(WKLD0,"^",10))_"</Cost>")
  1. . D ADD^VBECRPC("<WeightMultiplier>"_$$CHARCHK^XOBVLIB(WGHT)_"</WeightMultiplier>")
  1. . I $D(^LAM("AD",X,"CPT")) D
  1. . . S Y=0
  1. . . F S Y=$O(^LAM("AD",X,"CPT",Y)) Q:Y']"" D
  1. . . . I $P(^LAM(X,4,Y,0),"^",4)]"" Q
  1. . . . D ADD^VBECRPC("<CPTCode>"_$$CHARCHK^XOBVLIB(+^LAM(X,4,Y,0))_"</CPTCode>")
  1. . D ENDROOT^VBECRPC("Code")
  1. . Q
  1. D ENDROOT^VBECRPC("Workload")
  1. Q
  1. ;
  1. KILL ;
  1. K VBECCNT,CNT,X
  1. Q