Routine: SDUPDATECONSPID

SDUPDATECONSPID ;ALB/BLB -  Feb 29, 2024 - Entry point for SD PID/CID UPDATE OR protocol - attached to GMRC EVSEND OR

 ;;5.3;Scheduling;**877,885**;Aug 13, 1993;Build 5

 ;;Per VHA Directive 6402, this routine should not be modified

UPDATECONSULTPID(CONSULT) ;

 N CONSULTIEN,PID,DFN,COUNT

 I $D(SDCONTEXT)!($L($G(CANBYCLINORPAT)))!($L($G(SDECTYP))) Q

 I $D(APPOINTMENT) Q

 I $G(SDDDT)!($D(APPTARRAY)) Q

 I $L($G(NOSHOW))!($L($G(SDECNS))) Q

 I $D(NOSHOW) Q

 S COUNT=0

 F  S COUNT=$O(CONSULT(COUNT)) Q:'COUNT  D

 .I $E($G(CONSULT(COUNT)),1,3)="ORC" D

 ..S CONSULTIEN=$P($P($P($G(CONSULT(COUNT)),U,2),"|",2),";")

 ..S PID=$$HL7TFM^XLFDT($P($G(CONSULT(COUNT)),U,6))

.;

 .I $E($G(CONSULT(COUNT)),1,3)="PID" D

 ..S DFN=$P($G(CONSULT(COUNT)),"|",4)

 I '$G(CONSULTIEN)!('$G(DFN))!('$G(PID)) Q

 D UPDATECONSULTPID^SDES2APPTUTIL(CONSULTIEN,PID,DFN) ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUPDATECONSPID   893     printed  Feb 19, 2025@00:28:20                                                                                                                                                                                              Page 2

SDUPDATECONSPID ;ALB/BLB -  Feb 29, 2024 - Entry point for SD PID/CID UPDATE OR protocol - attached to GMRC EVSEND OR

 +1       ;;5.3;Scheduling;**877,885**;Aug 13, 1993;Build 5

 +2       ;;Per VHA Directive 6402, this routine should not be modified

 +3       ;

 +4        QUIT

 +5       ;

UPDATECONSULTPID(CONSULT) ;

 +1        NEW CONSULTIEN,PID,DFN,COUNT

 +2       ;

 +3        IF $DATA(SDCONTEXT)!($LENGTH($GET(CANBYCLINORPAT)))!($LENGTH($GET(SDECTYP)))

               QUIT

 +4        IF $DATA(APPOINTMENT)

               QUIT

 +5        IF $GET(SDDDT)!($DATA(APPTARRAY))

               QUIT

 +6        IF $LENGTH($GET(NOSHOW))!($LENGTH($GET(SDECNS)))

               QUIT

 +7        IF $DATA(NOSHOW)

               QUIT

 +8       ;

 +9        SET COUNT=0

 +10       FOR

               SET COUNT=$ORDER(CONSULT(COUNT))

               if 'COUNT

                   QUIT

               Begin DoDot:1

 +11               IF $EXTRACT($GET(CONSULT(COUNT)),1,3)="ORC"

                       Begin DoDot:2

 +12                       SET CONSULTIEN=$PIECE($PIECE($PIECE($GET(CONSULT(COUNT)),U,2),"|",2),";")

 +13                       SET PID=$$HL7TFM^XLFDT($PIECE($GET(CONSULT(COUNT)),U,6))

                       End DoDot:2

 +14      ;

 +15               IF $EXTRACT($GET(CONSULT(COUNT)),1,3)="PID"

                       Begin DoDot:2

 +16                       SET DFN=$PIECE($GET(CONSULT(COUNT)),"|",4)

                       End DoDot:2

               End DoDot:1

 +17       IF '$GET(CONSULTIEN)!('$GET(DFN))!('$GET(PID))

               QUIT

 +18      ;

 +19      ;

           DO UPDATECONSULTPID^SDES2APPTUTIL(CONSULTIEN,PID,DFN)

 +20       QUIT

 +21      ;

SDUPDATECONSPID.m