PRCPRPC1.m

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 ---PRCPRPC1   1538     printed  Apr 09, 2024@21:20:27                                                                                                                                                                                                    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