SDUPDATECONSPID.m

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

 ;;5.3;Scheduling;**877**;Aug 13, 1993;Build 14

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

 ;

 Q

 ;

UPDATECONSULTPID(CONSULT) ;6208

 N CONSULTIEN,PID,DFN,COUNT

 ;

 I $G(NEWPID) 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) ;

 Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SDUPDATECONSPID   848     printed  Sep 02, 2024@19:46:41                                                                                                                                                                                              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**;Aug 13, 1993;Build 14

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

 +3       ;

 +4        QUIT 

 +5       ;

UPDATECONSULTPID(CONSULT) ;6208

 +1        NEW CONSULTIEN,PID,DFN,COUNT

 +2       ;

 +3        IF $GET(NEWPID)

               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      ;