RMPR29CB.m

RMPR29CB ;OI-HINES/HNC/SPS -WORK ORDER SUSPENSE RPC CONT.;06/06/2006

 ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25

CANOTE ;(#12) CANCELLATION NOTE

 ;set file 668

 ;^RMPR(668,D0,4,0)=^668.012^^

 ;if status is cancelled, RMSUSTAT= 3 or 4

 ;RMPRTXT ;load into field #12

 ;^RMPR(668,D0,4,D1,0)

 ;

 S RMWONE=$P(^RMPR(664.1,RMPR6641,0),U,13)

 I RMSUSTAT=4 D EN2^RMPROWL(RMIE68,RMWONE)

 I $P(^RMPR(668,RMIE68,0),U,10)="C" S RESULTS(0)="0^This Suspense has already been Closed!"

 ;Update file 664.1 664.2 Delete 660 on Cancel out

 S DIE="^RMPR(664.1,",DA=RMPR6641

 S DR="16////^S X=""CA"";7////^S X=DUZ;8///^S X=DT" D ^DIE

 K DR,DA,DIE

 S RMIE=0,DIK="^RMPR(660,"

 F  S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0  D

 .S DA=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) D ^DIK

 .S $P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5)=""

 .S RMPRIE2=$P($G(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6)

 .I +RMPRIE2>0 S $P(^RMPR(664.2,RMPRIE2,0),U,2)=""

 .K ^RMPR(664.2,"C",DA)

 K DIK

 S DA=RMIE68

 D NOW^%DTC S RMPREODT=%,GMRCAD=%

 S DIE="^RMPR(668,"

 S DR="18////^S X=RMPREODT;17////^S X=DUZ;14///^S X=""X""" D ^DIE

 N RMPRC

 S L="",LN=0

 F  S L=$O(RMPRTXT(L)) Q:L=""  D

 . I 'LN D  Q:RMPRC=""  ;strip leading space from 1st line, ignore blank line

 .. S RMPRC=$E($TR(RMPRTXT(L)," ","")) ;1st non space char

 .. S:RMPRC'="" RMPRTXT(L)=$E(RMPRTXT(L),$F(RMPRTXT(L),RMPRC)-1,$L(RMPRTXT(L))) ;extract from 1st non space char to end of line

 .. Q

 . S LN=LN+1,^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L)

 . Q

 S $P(^RMPR(668,RMIE68,4,0),"^",3)=LN

 K L,LN

 ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK

 I '$P(^RMPR(668,DA,0),U,9) D

 .S DIE="^RMPR(668,"

 .S DR="7///^S X=""See Completion Note for Initial Action Taken."""

 .D ^DIE

 .S DR="10////^S X=RMPREODT;16////^S X=DUZ" D ^DIE

 K RMPREODT

 S GMRCO=$P(^RMPR(668,RMIE68,0),U,15)

 I GMRCO="" S RESULTS(0)="0^Completed Manual Suspense Action.  Suspense status has been updated to CANCELLED." Q

 S RMPRCOM=0

 F  S RMPRCOM=$O(^RMPR(668,RMIE68,4,RMPRCOM)) Q:RMPRCOM=""  D

 .S GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0)

 I $G(GMRCOM)="" S GMRCOM="Not Noted"

 S GMRCSF="U"

 S GMRCA=19

 S GMRCALF="N"

 S GMRCATO=""

 S (GMRCORNP,GMRCDUZ)=DUZ

 S BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD)

 I +BDC=1 S RESULTS(0)=1_"^"_$P(BDC,U,2)

 K GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD

 I RESULTS(0)="" S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult.  Suspense status has been updated to CANCELLED."

 Q

EXIT K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR6641,RMIE68

 K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT

 K BDC,BAD,%,RMINDT,RMPREQU,RMPRCOM,RMWONE,RMPRIE2

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPR29CB   2771     printed  Feb 18, 2025@23:58:36                                                                                                                                                                                                    Page 2

RMPR29CB  ;OI-HINES/HNC/SPS -WORK ORDER SUSPENSE RPC CONT.;06/06/2006

 +1       ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25

CANOTE    ;(#12) CANCELLATION NOTE

 +1       ;set file 668

 +2       ;^RMPR(668,D0,4,0)=^668.012^^

 +3       ;if status is cancelled, RMSUSTAT= 3 or 4

 +4       ;RMPRTXT ;load into field #12

 +5       ;^RMPR(668,D0,4,D1,0)

 +6       ;

 +7        SET RMWONE=$PIECE(^RMPR(664.1,RMPR6641,0),U,13)

 +8        IF RMSUSTAT=4

               DO EN2^RMPROWL(RMIE68,RMWONE)

 +9        IF $PIECE(^RMPR(668,RMIE68,0),U,10)="C"

               SET RESULTS(0)="0^This Suspense has already been Closed!"

 +10      ;Update file 664.1 664.2 Delete 660 on Cancel out

 +11       SET DIE="^RMPR(664.1,"

           SET DA=RMPR6641

 +12       SET DR="16////^S X=""CA"";7////^S X=DUZ;8///^S X=DT"

           DO ^DIE

 +13       KILL DR,DA,DIE

 +14       SET RMIE=0

           SET DIK="^RMPR(660,"

 +15       FOR 

               SET RMIE=$ORDER(^RMPR(664.1,RMPR6641,2,RMIE))

               if RMIE'>0

                   QUIT 

               Begin DoDot:1

 +16               SET DA=$PIECE(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5)

                   DO ^DIK

 +17               SET $PIECE(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5)=""

 +18               SET RMPRIE2=$PIECE($GET(^RMPR(664.1,RMPR6641,2,RMIE,0)),U,6)

 +19               IF +RMPRIE2>0

                       SET $PIECE(^RMPR(664.2,RMPRIE2,0),U,2)=""

 +20               KILL ^RMPR(664.2,"C",DA)

               End DoDot:1

 +21       KILL DIK

 +22       SET DA=RMIE68

 +23       DO NOW^%DTC

           SET RMPREODT=%

           SET GMRCAD=%

 +24       SET DIE="^RMPR(668,"

 +25       SET DR="18////^S X=RMPREODT;17////^S X=DUZ;14///^S X=""X"""

           DO ^DIE

 +26       NEW RMPRC

 +27       SET L=""

           SET LN=0

 +28       FOR 

               SET L=$ORDER(RMPRTXT(L))

               if L=""

                   QUIT 

               Begin DoDot:1

 +29      ;strip leading space from 1st line, ignore blank line

                   IF 'LN

                       Begin DoDot:2

 +30      ;1st non space char

                           SET RMPRC=$EXTRACT($TRANSLATE(RMPRTXT(L)," ",""))

 +31      ;extract from 1st non space char to end of line

                           if RMPRC'=""

                               SET RMPRTXT(L)=$EXTRACT(RMPRTXT(L),$FIND(RMPRTXT(L),RMPRC)-1,$LENGTH(RMPRTXT(L)))

 +32                       QUIT 

                       End DoDot:2

                       if RMPRC=""

                           QUIT 

 +33               SET LN=LN+1

                   SET ^RMPR(668,RMIE68,4,LN,0)=RMPRTXT(L)

 +34               QUIT 

               End DoDot:1

 +35       SET $PIECE(^RMPR(668,RMIE68,4,0),"^",3)=LN

 +36       KILL L,LN

 +37      ;S DA=RMIE68,DIK="^RMPR(668," D IX1^DIK

 +38       IF '$PIECE(^RMPR(668,DA,0),U,9)

               Begin DoDot:1

 +39               SET DIE="^RMPR(668,"

 +40               SET DR="7///^S X=""See Completion Note for Initial Action Taken."""

 +41               DO ^DIE

 +42               SET DR="10////^S X=RMPREODT;16////^S X=DUZ"

                   DO ^DIE

               End DoDot:1

 +43       KILL RMPREODT

 +44       SET GMRCO=$PIECE(^RMPR(668,RMIE68,0),U,15)

 +45       IF GMRCO=""

               SET RESULTS(0)="0^Completed Manual Suspense Action.  Suspense status has been updated to CANCELLED."

               QUIT 

 +46       SET RMPRCOM=0

 +47       FOR 

               SET RMPRCOM=$ORDER(^RMPR(668,RMIE68,4,RMPRCOM))

               if RMPRCOM=""

                   QUIT 

               Begin DoDot:1

 +48               SET GMRCOM(RMPRCOM)=^RMPR(668,RMIE68,4,RMPRCOM,0)

               End DoDot:1

 +49       IF $GET(GMRCOM)=""

               SET GMRCOM="Not Noted"

 +50       SET GMRCSF="U"

 +51       SET GMRCA=19

 +52       SET GMRCALF="N"

 +53       SET GMRCATO=""

 +54       SET (GMRCORNP,GMRCDUZ)=DUZ

 +55       SET BDC=$$SFILE^GMRCGUIB(.GMRCO,.GMRCA,.GMRCSF,.GMRCORNP,.GMRCDUZ,.GMRCOM,.GMRCALF,.GMRCATO,.GMRCAD)

 +56       IF +BDC=1

               SET RESULTS(0)=1_"^"_$PIECE(BDC,U,2)

 +57       KILL GMRCO,GMRCA,GMRCSF,GMRCORNP,GMRCDUZ,GMRCOM,GMRCALF,GMRCATO,GMRCAD

 +58       IF RESULTS(0)=""

               SET RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult.  Suspense status has been updated to CANCELLED."

 +59       QUIT 

EXIT       KILL RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR6641,RMIE68

 +1        KILL RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT

 +2        KILL BDC,BAD,%,RMINDT,RMPREQU,RMPRCOM,RMWONE,RMPRIE2