- 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 Feb 18, 2025@23:41:35 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