source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRPC1.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.5 KB
Line 
1PRCPRPC1 ;WISC/RFJ,DWA-patient distribution costs (sort) ;11 Mar 94
2 ;;5.1;IFCAP;**27**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7SORT ; sort data
8 K ^TMP($J,"PRCPRPCR"),^TMP($J,"PRCPRPCRT")
9 S DA=DATESTRT-.00000001
10 F S DA=$O(^PRCP(446.1,DA)) Q:'DA!($P(DA,".")>DATEEND) S DATA=$G(^(DA,0)),SURGDATA=$G(^(130)) I DATA'="" D
11 . ; check distribution point
12 . S DISTRPT=+$P(DATA,"^",6)
13 . I 'DISTRPT,'$G(DISTRALL) Q
14 . I $G(DISTRALL),$D(^TMP($J,"PRCPURS3","NO",DISTRPT)) Q
15 . I '$G(DISTRALL),'$D(^TMP($J,"PRCPURS3","YES",DISTRPT)) Q
16 . S DISTRNM=$P($$INVNAME^PRCPUX1(DISTRPT),"-",2) S:DISTRNM="" DISTRNM=" "
17 . ;
18 . ; check surgical specialty
19 . S SURGSPEC=$P($G(^SRO(137.45,+$P(SURGDATA,"^",3),0)),"^") S:SURGSPEC="" SURGSPEC=" "
20 . I SURGSPEC']PRCPSURS!(PRCPSURE']SURGSPEC) Q
21 . ;
22 . ; check patient
23 . S DFN=+$P(DATA,"^",3),(PATNAME,SSN)=" " I $$VERSION^XPDUTL("DG"),DFN D DEM^VADPT
24 . S PATNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
25 . I PATNAME']PRCPPATS!(PRCPPATE']PATNAME) Q
26 . ;
27 . ; check opcode
28 . S OPCODE=$P($$ICPT^PRCPCUT1(+$P(SURGDATA,"^")),"^") I OPCODE="" S OPCODE=" "
29 . I OPCODE']PRCPOPCS!(PRCPOPCE']OPCODE) Q
30 . ;
31 . S INOUTPAT=$P(DATA,"^",4) I INOUTPAT="" S INOUTPAT=" "
32 . 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)
33 Q
Note: See TracBrowser for help on using the repository browser.