PRCPRPC1 ;WISC/RFJ,DWA-patient distribution costs (sort) ; 06/23/2009 2:12 PM
;;5.1;IFCAP;**27,136**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;
SORT ; sort data
K ^TMP($J,"PRCPRPCR"),^TMP($J,"PRCPRPCRT")
S DA=DATESTRT-.00000001
F S DA=$O(^PRCP(446.1,DA)) Q:'DA!($P(DA,".")>DATEEND) S DATA=$G(^(DA,0)),SURGDATA=$G(^(130)) I DATA'="" D
. ; check distribution point
. S DISTRPT=+$P(DATA,"^",6)
. I 'DISTRPT,'$G(DISTRALL) Q
. I $G(DISTRALL),$D(^TMP($J,"PRCPURS3","NO",DISTRPT)) Q
. I '$G(DISTRALL),'$D(^TMP($J,"PRCPURS3","YES",DISTRPT)) Q
. S DISTRNM=$P($$INVNAME^PRCPUX1(DISTRPT),"-",2) S:DISTRNM="" DISTRNM=" "
. ;
. ; check surgical specialty
. S SURGSPEC=$P($G(^SRO(137.45,+$P(SURGDATA,"^",3),0)),"^") S:SURGSPEC="" SURGSPEC=" "
. I SURGSPEC']PRCPSURS!(PRCPSURE']SURGSPEC) Q
. ;
. ; check patient
. S DFN=+$P(DATA,"^",3),(PATNAME,SSN)=" " I $$VERSION^XPDUTL("DG"),DFN D DEM^VADPT
. S PATNAME=$G(VADM(1)),SSN=$P($G(VADM(2)),"^",2)
. I PATNAME']PRCPPATS!(PRCPPATE']PATNAME) Q
. ;
. ; check opcode
. S OPCODE=$P($$ICPT^PRCPCUT1(+$P(SURGDATA,U),+DATA),"^") I OPCODE="" S OPCODE=" "
. I OPCODE']PRCPOPCS!(PRCPOPCE']OPCODE) Q
. ;
. S INOUTPAT=$P(DATA,"^",4) I INOUTPAT="" S INOUTPAT=" "
. 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)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPC1 1538 printed Oct 16, 2024@18:15:57 Page 2
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
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
SORT ; sort data
+1 KILL ^TMP($JOB,"PRCPRPCR"),^TMP($JOB,"PRCPRPCRT")
+2 SET DA=DATESTRT-.00000001
+3 FOR
SET DA=$ORDER(^PRCP(446.1,DA))
if 'DA!($PIECE(DA,".")>DATEEND)
QUIT
SET DATA=$GET(^(DA,0))
SET SURGDATA=$GET(^(130))
IF DATA'=""
Begin DoDot:1
+4 ; check distribution point
+5 SET DISTRPT=+$PIECE(DATA,"^",6)
+6 IF 'DISTRPT
IF '$GET(DISTRALL)
QUIT
+7 IF $GET(DISTRALL)
IF $DATA(^TMP($JOB,"PRCPURS3","NO",DISTRPT))
QUIT
+8 IF '$GET(DISTRALL)
IF '$DATA(^TMP($JOB,"PRCPURS3","YES",DISTRPT))
QUIT
+9 SET DISTRNM=$PIECE($$INVNAME^PRCPUX1(DISTRPT),"-",2)
if DISTRNM=""
SET DISTRNM=" "
+10 ;
+11 ; check surgical specialty
+12 SET SURGSPEC=$PIECE($GET(^SRO(137.45,+$PIECE(SURGDATA,"^",3),0)),"^")
if SURGSPEC=""
SET SURGSPEC=" "
+13 IF SURGSPEC']PRCPSURS!(PRCPSURE']SURGSPEC)
QUIT
+14 ;
+15 ; check patient
+16 SET DFN=+$PIECE(DATA,"^",3)
SET (PATNAME,SSN)=" "
IF $$VERSION^XPDUTL("DG")
IF DFN
DO DEM^VADPT
+17 SET PATNAME=$GET(VADM(1))
SET SSN=$PIECE($GET(VADM(2)),"^",2)
+18 IF PATNAME']PRCPPATS!(PRCPPATE']PATNAME)
QUIT
+19 ;
+20 ; check opcode
+21 SET OPCODE=$PIECE($$ICPT^PRCPCUT1(+$PIECE(SURGDATA,U),+DATA),"^")
IF OPCODE=""
SET OPCODE=" "
+22 IF OPCODE']PRCPOPCS!(PRCPOPCE']OPCODE)
QUIT
+23 ;
+24 SET INOUTPAT=$PIECE(DATA,"^",4)
IF INOUTPAT=""
SET INOUTPAT=" "
+25 SET ^TMP($JOB,"PRCPRPCR",$EXTRACT(DISTRNM,1,15),$EXTRACT(SURGSPEC,1,15),INOUTPAT,$EXTRACT($PIECE(PATNAME,","),1,4)_"-"_$EXTRACT($PIECE(SSN,"-",3),1,4),OPCODE,DA)=$PIECE(SURGDATA,"^",2)_"^"_$PIECE(SURGDATA,"^",4)_"^"_$PIECE(DATA,"^",
5)
End DoDot:1
+26 QUIT
