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

PRCPRPC1.m

Go to the documentation of this file.
  1. PRCPRPC1 ;WISC/RFJ,DWA-patient distribution costs (sort) ; 06/23/2009 2:12 PM
  1. ;;5.1;IFCAP;**27,136**;Oct 20, 2000;Build 6
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. ;
  1. ;
  1. SORT ; sort data
  1. K ^TMP($J,"PRCPRPCR"),^TMP($J,"PRCPRPCRT")
  1. S DA=DATESTRT-.00000001
  1. F S DA=$O(^PRCP(446.1,DA)) Q:'DA!($P(DA,".")>DATEEND) S DATA=$G(^(DA,0)),SURGDATA=$G(^(130)) I DATA'="" D
  1. . ; check distribution point
  1. . S DISTRPT=+$P(DATA,"^",6)
  1. . I 'DISTRPT,'$G(DISTRALL) Q
  1. . I $G(DISTRALL),$D(^TMP($J,"PRCPURS3","NO",DISTRPT)) Q
  1. . I '$G(DISTRALL),'$D(^TMP($J,"PRCPURS3","YES",DISTRPT)) Q
  1. . S DISTRNM=$P($$INVNAME^PRCPUX1(DISTRPT),"-",2) S:DISTRNM="" DISTRNM=" "
  1. . ;
  1. . ; check surgical specialty
  1. . S SURGSPEC=$P($G(^SRO(137.45,+$P(SURGDATA,"^",3),0)),"^") S:SURGSPEC="" SURGSPEC=" "
  1. . I SURGSPEC']PRCPSURS!(PRCPSURE']SURGSPEC) Q
  1. . ;
  1. . ; check patient
  1. . S DFN=+$P(DATA,"^",3),(PATNAME,SSN)=" " I $$VERSION^XPDUTL("DG"),DFN D DEM^VADPT
  1. . S PATNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
  1. . I PATNAME']PRCPPATS!(PRCPPATE']PATNAME) Q
  1. . ;
  1. . ; check opcode
  1. . S OPCODE=$P($$ICPT^PRCPCUT1(+$P(SURGDATA,U),+DATA),"^") I OPCODE="" S OPCODE=" "
  1. . I OPCODE']PRCPOPCS!(PRCPOPCE']OPCODE) Q
  1. . ;
  1. . S INOUTPAT=$P(DATA,"^",4) I INOUTPAT="" S INOUTPAT=" "
  1. . S ^TMP($J,"PRCPRPCR",$E(DISTRNM,1,15),$E(SURGSPEC,1,15),INOUTPAT,$E($P(PATNAME,","),1,4)_"-"_$E($P(SSN,"-",3),1,4),OPCODE,DA)=$P(SURGDATA,"^",2)_"^"_$P(SURGDATA,"^",4)_"^"_$P(DATA,"^",5)
  1. Q