RMPR4E23.m

RMPR4E23 ;HINES CIOFO/TH - PROMPT FOR SHIPMENT DATE ;08/05/03

 ;;3.0;PROSTHETICS;**78,114,118**;Feb 09, 1996

 ;

 ;TH 08/05/03 Patch #78 - Add shipment date.

 ;                      - DBIA #3427

 ;

 ; RMIFCAP = IFCAP Order

 ; RMPRTRDT = Transaction Date from file #440.6

 ; RMPRSHIP = Shipment Date

 ;

 S (RMIFCAP,RMPRTRDT,RMPRSHIP)=""

 ; Set default to today's date

 S RMPRTRDT=DT

 I $D(^RMPR(664,RMPRA)) D

 . Q:'$D(^RMPR(664,RMPRA,4))

 . S RMIFCAP=$P(^RMPR(664,RMPRA,4),U,6) Q:RMIFCAP=""

 . I $D(^PRCH(440.6,"PO",RMIFCAP)) D

 . . S D1="",D1=$O(^PRCH(440.6,"PO",RMIFCAP,D1),-1) Q:D1=""

 . . Q:'$D(^PRCH(440.6,D1,0))

 . . S RMPRTRDT=$$GET1^DIQ(440.6,D1,6,"I")

 S RMPRTRDT=$$FMTE^XLFDT(RMPRTRDT,"2D")

 D GETDT,BILL,EXIT

 Q

 ;

GETDT ; DIR call to obtain the shipment date

 Q:$G(DA)=""

 I $G(SKPSHDT)=1 D  G GETDT1  ;SKPSHDT set in RMPR4E21 to auto set ship date to trans date

 . S RMPRSHIP=DT

 . I RMPRTRDT'="" S X=RMPRTRDT K %DT D ^%DT S RMPRSHIP=Y

 K DIR,DIRUT

 S DIR(0)="D",DIR("A")="Shipment Date",DIR("B")=$G(RMPRTRDT)

 S DIR("?")="The date that the item shipped to the patient. The default"

 S DIR("?")=DIR("?")_" date would be the transaction date from IFCAP."

 D ^DIR

 S RMPRSHIP=Y

GETDT1 G:'$D(^RMPR(660,DA)) EXIT

 G:RMPRSHIP="" EXIT

 ; Shipment Date/Date of Service filed in file #660.

 I DA'="" S $P(^RMPR(660,DA,1),U,8)=RMPRSHIP

 Q

 ;

BILL ; File to #660.5 - ready to bill

 Q  ; taken out for phase II Billing Aware (WLC 02/26/04)

 N DIC,X,DLAYGO,DIR

 S DIC="^RMPR(660.5,"

 S DIC(0)="L",X="""N"""

 S DLAYGO=660.5 D ^DIC K DLAYGO Q:Y<1

 S RMPRO=+Y,DIE=DIC

 ;

 L +^RMPR(660.5,RMPRO)

 ; .01-Transaction Date; 2-Send Required; .02-Shipment Date

 ; 3-ProsFile(pointer to file #660)

 S DR=".01////^S X=DT;2////1;.02////^S X=RMPRSHIP;3////^S X=DA"

 D ^DIE

 L -^RMPR(660.5,RMPRO)

 Q

 ;

EXIT ; Exit

 K DA,DIC,DIE,DR,RMIFCAP,RMPRTRDT,RMPRSHIP

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPR4E23   1905     printed  Mar 13, 2025@21:37:40                                                                                                                                                                                                    Page 2

RMPR4E23  ;HINES CIOFO/TH - PROMPT FOR SHIPMENT DATE ;08/05/03

 +1       ;;3.0;PROSTHETICS;**78,114,118**;Feb 09, 1996

 +2       ;

 +3       ;TH 08/05/03 Patch #78 - Add shipment date.

 +4       ;                      - DBIA #3427

 +5       ;

 +6       ; RMIFCAP = IFCAP Order

 +7       ; RMPRTRDT = Transaction Date from file #440.6

 +8       ; RMPRSHIP = Shipment Date

 +9       ;

 +10       SET (RMIFCAP,RMPRTRDT,RMPRSHIP)=""

 +11      ; Set default to today's date

 +12       SET RMPRTRDT=DT

 +13       IF $DATA(^RMPR(664,RMPRA))

               Begin DoDot:1

 +14               if '$DATA(^RMPR(664,RMPRA,4))

                       QUIT 

 +15               SET RMIFCAP=$PIECE(^RMPR(664,RMPRA,4),U,6)

                   if RMIFCAP=""

                       QUIT 

 +16               IF $DATA(^PRCH(440.6,"PO",RMIFCAP))

                       Begin DoDot:2

 +17                       SET D1=""

                           SET D1=$ORDER(^PRCH(440.6,"PO",RMIFCAP,D1),-1)

                           if D1=""

                               QUIT 

 +18                       if '$DATA(^PRCH(440.6,D1,0))

                               QUIT 

 +19                       SET RMPRTRDT=$$GET1^DIQ(440.6,D1,6,"I")

                       End DoDot:2

               End DoDot:1

 +20       SET RMPRTRDT=$$FMTE^XLFDT(RMPRTRDT,"2D")

 +21       DO GETDT

           DO BILL

           DO EXIT

 +22       QUIT 

 +23      ;

GETDT     ; DIR call to obtain the shipment date

 +1        if $GET(DA)=""

               QUIT 

 +2       ;SKPSHDT set in RMPR4E21 to auto set ship date to trans date

           IF $GET(SKPSHDT)=1

               Begin DoDot:1

 +3                SET RMPRSHIP=DT

 +4                IF RMPRTRDT'=""

                       SET X=RMPRTRDT

                       KILL %DT

                       DO ^%DT

                       SET RMPRSHIP=Y

               End DoDot:1

               GOTO GETDT1

 +5        KILL DIR,DIRUT

 +6        SET DIR(0)="D"

           SET DIR("A")="Shipment Date"

           SET DIR("B")=$GET(RMPRTRDT)

 +7        SET DIR("?")="The date that the item shipped to the patient. The default"

 +8        SET DIR("?")=DIR("?")_" date would be the transaction date from IFCAP."

 +9        DO ^DIR

 +10       SET RMPRSHIP=Y

GETDT1     if '$DATA(^RMPR(660,DA))

               GOTO EXIT

 +1        if RMPRSHIP=""

               GOTO EXIT

 +2       ; Shipment Date/Date of Service filed in file #660.

 +3        IF DA'=""

               SET $PIECE(^RMPR(660,DA,1),U,8)=RMPRSHIP

 +4        QUIT 

 +5       ;

BILL      ; File to #660.5 - ready to bill

 +1       ; taken out for phase II Billing Aware (WLC 02/26/04)

           QUIT 

 +2        NEW DIC,X,DLAYGO,DIR

 +3        SET DIC="^RMPR(660.5,"

 +4        SET DIC(0)="L"

           SET X="""N"""

 +5        SET DLAYGO=660.5

           DO ^DIC

           KILL DLAYGO

           if Y<1

               QUIT 

 +6        SET RMPRO=+Y

           SET DIE=DIC

 +7       ;

 +8        LOCK +^RMPR(660.5,RMPRO)

 +9       ; .01-Transaction Date; 2-Send Required; .02-Shipment Date

 +10      ; 3-ProsFile(pointer to file #660)

 +11       SET DR=".01////^S X=DT;2////1;.02////^S X=RMPRSHIP;3////^S X=DA"

 +12       DO ^DIE

 +13       LOCK -^RMPR(660.5,RMPRO)

 +14       QUIT 

 +15      ;

EXIT      ; Exit

 +1        KILL DA,DIC,DIE,DR,RMIFCAP,RMPRTRDT,RMPRSHIP

 +2        QUIT