RMPREOSA ;HINES-IOFO/HNC,RN,ATG/JPN - Clone, Auto Adaptive, Clothing Allowance ;July 29, 2020@10:00
;;3.0;PROSTHETICS;**80,75,200**;Feb 09, 1996;Build 2
EN ;Add Auto Adaptive Suspense
;
; VSR (RN) patch RMPR*3.0*200 change four slashes to three slashes for validation before filing adding back tic to station
D NOW^%DTC S X=%
S DIC="^RMPR(668,",DIC(0)="AEQLM",DLAYGO=668
S DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^S X=8;3////^S X=9;2///^S X=""`""_RMPR(""STA"")"
K DINUM,D0,DD,DO D FILE^DICN K DLAYGO G:Y'>0 EX S (RDA,DA)=+Y
S DIE="^RMPR(668,",DR="13;4"
L +^RMPR(668,RDA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
D ^DIE L -^RMPR(668,RDA,0)
I '$P(^RMPR(668,RDA,0),U,3) S DA=RDA,DIK="^RMPR(668," D ^DIK W !,$C(7),?5,"Deleted..."
EX K X,DIC,DIE,DR,Y
Q
;
EN1 ;Add Clothing Allowance Suspense
;
; VSR (RN) patch RMPR*3.0*200 change four slashes to three slashes for validation before filing adding back tic to station
D NOW^%DTC S X=%
S DIC="^RMPR(668,",DIC(0)="AEQLM",DLAYGO=668
S DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^ S X=6;3////^S X=9;2///^S X=""`""_RMPR(""STA"")"
K DINUM,D0,DD,DO D FILE^DICN K DLAYGO G:Y'>0 EX S (RDA,DA)=+Y
S DIE="^RMPR(668,",DR="13;4"
L +^RMPR(668,RDA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
D ^DIE L -^RMPR(668,RDA,0)
I '$P(^RMPR(668,RDA,0),U,3) S DA=RDA,DIK="^RMPR(668," D ^DIK W !,$C(7),?5,"Deleted..."
K X,DIC,DIE,DR,Y
Q
EN2 ;Create Clone CPRS Suspense
;
N RMPR9
S RMPR9=$P(^RMPR(668,DA,0),U,8)
I $P(^RMPR(668,DA,0),U,8)>4&(RMPR9'=9)&(RMPR9'=11) W !!!,"Only CPRS Suspense Can Be Cloned!",!! H 2 Q
I $P(^RMPR(668,DA,0),U,8)=11&($P($G(^RMPR(668,DA,0)),U,15)'>0) W !!!,"This was a Manual Request, not a CPRS Suspense. Please create another Manual.",!! H 2 Q
ST2 S RMPRH=DA
S (RMPRFLD,RMPRFI,RMPRFW)=0
D GETS^DIQ(668,RMPRH,"**","I","OUT")
Q:'$D(OUT)
;create new record
D NOW^%DTC S X=%
S DIC="^RMPR(668,",DIC(0)="L"
K DD,DO D FILE^DICN
S RMPRA=+Y
M R6681(668,RMPRA_",")=OUT(668,RMPRH_",")
F S RMPRFLD=$O(R6681(668,RMPRA_",",RMPRFLD)) Q:RMPRFLD'>0 D
. F S RMPRFI=$O(R6681(668,RMPRA_",",RMPRFLD,RMPRFI)) Q:RMPRFI="" D
.. I RMPRFI="I" S R668(668,RMPRA_",",RMPRFLD)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI) Q
.. S R668(668,RMPRA_",",RMPRFLD,RMPRFI)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI)
S RMPRC=RMPRA_","
S R668(668,RMPRA_",",4)="R668(668,"_""""_RMPRC_""""_",4)"
I $D(R668(668,RMPRA_",",7)) S R668(668,RMPRA_",",7)="R668(668,"_""""_RMPRC_""""_",7)"
K OUT
;
;don't set the following fields
K R668(668,RMPRA_",",.01)
;urgency
K R668(668,RMPRA_",",2.3)
;completion date
K R668(668,RMPRA_",",5)
;completed by
K R668(668,RMPRA_",",6)
;initial action note
K R668(668,RMPRA_",",7)
;suspended by
S R668(668,RMPRA_",",8)=DUZ
;patient 2319
K R668(668,RMPRA_",",8.1)
;amis grouper
K R668(668,RMPRA_",",8.2)
;init action date
K R668(668,RMPRA_",",10)
;completion note
K R668(668,RMPRA_",",12)
;initial action by
K R668(668,RMPRA_",",16)
;cancelled by
K R668(668,RMPRA_",",17)
;cancel date
K R668(668,RMPRA_",",18)
;CPRS order may be purged, remobe
K R668(668,RMPRA_",",19)
;cancel note
K R668(668,RMPRA_",",21)
;date rx written, keep same per Karen 9/15/03
;K R668(668,RMPRA_",",22)
;consult service
K R668(668,RMPRA_",",23)
;consult needed for display set to orig pointer
S R668(668,RMPRA_",",20)=$P(^RMPR(668,RMPRH,0),U,15)
;forwarded by
K R668(668,RMPRA_",",24)
;consult visit
K R668(668,RMPRA_",",30)
;set status to open
S R668(668,RMPRA_",",14)="O"
;set type to clone
S R668(668,RMPRA_",",9)=7
;will automatically set the Billing Fields as needed IF NO DUPLICATES!
;32,32.1,32.2,33,33.1,33.2,33.3
S DIC="^RMPR(668,",DIC(0)="AEQM"
D FILE^DIE("K","R668","ERROR")
I $D(ERROR) W !,ERROR("DIERR",1,"TEXT",1),!,"Could NOT CLONE DUE TO BAD DATA!" H 2 K ERROR,R668 G KILL
;file field #1 Veteran
;S DA=RMPRA
;S DIE="^RMPR(668,"
;S DR="1////^S X=RMPRDFN"
;L +^RMPR(668,RMPRA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
;D ^DIE L -^RMPR(668,RMPRA,0)
;print view request, ask for device
W !!,"Done... Please select a device to print the new SUSPENSE Record."
S DA=RMPRA
S L=0
S DIC="^RMPR(668,",FLDS="[RMPR VIEW REQUEST]"
S BY="@NUMBER",(FR,TO)=DA
D EN1^DIP
N DIR S DIR(0)="E" D ^DIR
W @IOF
S DA=^TMP($J,"RMPREOEE",XDA,0)
D VALL^RMPREO24(DA,.L) Q:L="^"
K RMPRA,RMPRC,DFN,DA,DIC,X,Y
Q
KILL ;get rid of new clone if error
S DA=RMPRA,DIK=668 D ^DIK
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPREOSA 4633 printed Dec 13, 2024@02:34:30 Page 2
RMPREOSA ;HINES-IOFO/HNC,RN,ATG/JPN - Clone, Auto Adaptive, Clothing Allowance ;July 29, 2020@10:00
+1 ;;3.0;PROSTHETICS;**80,75,200**;Feb 09, 1996;Build 2
EN ;Add Auto Adaptive Suspense
+1 ;
+2 ; VSR (RN) patch RMPR*3.0*200 change four slashes to three slashes for validation before filing adding back tic to station
+3 DO NOW^%DTC
SET X=%
+4 SET DIC="^RMPR(668,"
SET DIC(0)="AEQLM"
SET DLAYGO=668
+5 SET DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^S X=8;3////^S X=9;2///^S X=""`""_RMPR(""STA"")"
+6 KILL DINUM,D0,DD,DO
DO FILE^DICN
KILL DLAYGO
if Y'>0
GOTO EX
SET (RDA,DA)=+Y
+7 SET DIE="^RMPR(668,"
SET DR="13;4"
+8 LOCK +^RMPR(668,RDA,0):1
IF $TEST=0
WRITE $CHAR(7),?5,!,"Someone else is editing this record"
GOTO EX
+9 DO ^DIE
LOCK -^RMPR(668,RDA,0)
+10 IF '$PIECE(^RMPR(668,RDA,0),U,3)
SET DA=RDA
SET DIK="^RMPR(668,"
DO ^DIK
WRITE !,$CHAR(7),?5,"Deleted..."
EX KILL X,DIC,DIE,DR,Y
+1 QUIT
+2 ;
EN1 ;Add Clothing Allowance Suspense
+1 ;
+2 ; VSR (RN) patch RMPR*3.0*200 change four slashes to three slashes for validation before filing adding back tic to station
+3 DO NOW^%DTC
SET X=%
+4 SET DIC="^RMPR(668,"
SET DIC(0)="AEQLM"
SET DLAYGO=668
+5 SET DIC("DR")="1////^S X=RMPRDFN;22R;14////^S X=""O"";8////^S X=DUZ;9////^ S X=6;3////^S X=9;2///^S X=""`""_RMPR(""STA"")"
+6 KILL DINUM,D0,DD,DO
DO FILE^DICN
KILL DLAYGO
if Y'>0
GOTO EX
SET (RDA,DA)=+Y
+7 SET DIE="^RMPR(668,"
SET DR="13;4"
+8 LOCK +^RMPR(668,RDA,0):1
IF $TEST=0
WRITE $CHAR(7),?5,!,"Someone else is editing this record"
GOTO EX
+9 DO ^DIE
LOCK -^RMPR(668,RDA,0)
+10 IF '$PIECE(^RMPR(668,RDA,0),U,3)
SET DA=RDA
SET DIK="^RMPR(668,"
DO ^DIK
WRITE !,$CHAR(7),?5,"Deleted..."
+11 KILL X,DIC,DIE,DR,Y
+12 QUIT
EN2 ;Create Clone CPRS Suspense
+1 ;
+2 NEW RMPR9
+3 SET RMPR9=$PIECE(^RMPR(668,DA,0),U,8)
+4 IF $PIECE(^RMPR(668,DA,0),U,8)>4&(RMPR9'=9)&(RMPR9'=11)
WRITE !!!,"Only CPRS Suspense Can Be Cloned!",!!
HANG 2
QUIT
+5 IF $PIECE(^RMPR(668,DA,0),U,8)=11&($PIECE($GET(^RMPR(668,DA,0)),U,15)'>0)
WRITE !!!,"This was a Manual Request, not a CPRS Suspense. Please create another Manual.",!!
HANG 2
QUIT
ST2 SET RMPRH=DA
+1 SET (RMPRFLD,RMPRFI,RMPRFW)=0
+2 DO GETS^DIQ(668,RMPRH,"**","I","OUT")
+3 if '$DATA(OUT)
QUIT
+4 ;create new record
+5 DO NOW^%DTC
SET X=%
+6 SET DIC="^RMPR(668,"
SET DIC(0)="L"
+7 KILL DD,DO
DO FILE^DICN
+8 SET RMPRA=+Y
+9 MERGE R6681(668,RMPRA_",")=OUT(668,RMPRH_",")
+10 FOR
SET RMPRFLD=$ORDER(R6681(668,RMPRA_",",RMPRFLD))
if RMPRFLD'>0
QUIT
Begin DoDot:1
+11 FOR
SET RMPRFI=$ORDER(R6681(668,RMPRA_",",RMPRFLD,RMPRFI))
if RMPRFI=""
QUIT
Begin DoDot:2
+12 IF RMPRFI="I"
SET R668(668,RMPRA_",",RMPRFLD)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI)
QUIT
+13 SET R668(668,RMPRA_",",RMPRFLD,RMPRFI)=R6681(668,RMPRA_",",RMPRFLD,RMPRFI)
End DoDot:2
End DoDot:1
+14 SET RMPRC=RMPRA_","
+15 SET R668(668,RMPRA_",",4)="R668(668,"_""""_RMPRC_""""_",4)"
+16 IF $DATA(R668(668,RMPRA_",",7))
SET R668(668,RMPRA_",",7)="R668(668,"_""""_RMPRC_""""_",7)"
+17 KILL OUT
+18 ;
+19 ;don't set the following fields
+20 KILL R668(668,RMPRA_",",.01)
+21 ;urgency
+22 KILL R668(668,RMPRA_",",2.3)
+23 ;completion date
+24 KILL R668(668,RMPRA_",",5)
+25 ;completed by
+26 KILL R668(668,RMPRA_",",6)
+27 ;initial action note
+28 KILL R668(668,RMPRA_",",7)
+29 ;suspended by
+30 SET R668(668,RMPRA_",",8)=DUZ
+31 ;patient 2319
+32 KILL R668(668,RMPRA_",",8.1)
+33 ;amis grouper
+34 KILL R668(668,RMPRA_",",8.2)
+35 ;init action date
+36 KILL R668(668,RMPRA_",",10)
+37 ;completion note
+38 KILL R668(668,RMPRA_",",12)
+39 ;initial action by
+40 KILL R668(668,RMPRA_",",16)
+41 ;cancelled by
+42 KILL R668(668,RMPRA_",",17)
+43 ;cancel date
+44 KILL R668(668,RMPRA_",",18)
+45 ;CPRS order may be purged, remobe
+46 KILL R668(668,RMPRA_",",19)
+47 ;cancel note
+48 KILL R668(668,RMPRA_",",21)
+49 ;date rx written, keep same per Karen 9/15/03
+50 ;K R668(668,RMPRA_",",22)
+51 ;consult service
+52 KILL R668(668,RMPRA_",",23)
+53 ;consult needed for display set to orig pointer
+54 SET R668(668,RMPRA_",",20)=$PIECE(^RMPR(668,RMPRH,0),U,15)
+55 ;forwarded by
+56 KILL R668(668,RMPRA_",",24)
+57 ;consult visit
+58 KILL R668(668,RMPRA_",",30)
+59 ;set status to open
+60 SET R668(668,RMPRA_",",14)="O"
+61 ;set type to clone
+62 SET R668(668,RMPRA_",",9)=7
+63 ;will automatically set the Billing Fields as needed IF NO DUPLICATES!
+64 ;32,32.1,32.2,33,33.1,33.2,33.3
+65 SET DIC="^RMPR(668,"
SET DIC(0)="AEQM"
+66 DO FILE^DIE("K","R668","ERROR")
+67 IF $DATA(ERROR)
WRITE !,ERROR("DIERR",1,"TEXT",1),!,"Could NOT CLONE DUE TO BAD DATA!"
HANG 2
KILL ERROR,R668
GOTO KILL
+68 ;file field #1 Veteran
+69 ;S DA=RMPRA
+70 ;S DIE="^RMPR(668,"
+71 ;S DR="1////^S X=RMPRDFN"
+72 ;L +^RMPR(668,RMPRA,0):1 I $T=0 W $C(7),?5,!,"Someone else is editing this record" G EX
+73 ;D ^DIE L -^RMPR(668,RMPRA,0)
+74 ;print view request, ask for device
+75 WRITE !!,"Done... Please select a device to print the new SUSPENSE Record."
+76 SET DA=RMPRA
+77 SET L=0
+78 SET DIC="^RMPR(668,"
SET FLDS="[RMPR VIEW REQUEST]"
+79 SET BY="@NUMBER"
SET (FR,TO)=DA
+80 DO EN1^DIP
+81 NEW DIR
SET DIR(0)="E"
DO ^DIR
+82 WRITE @IOF
+83 SET DA=^TMP($JOB,"RMPREOEE",XDA,0)
+84 DO VALL^RMPREO24(DA,.L)
if L="^"
QUIT
+85 KILL RMPRA,RMPRC,DFN,DA,DIC,X,Y
+86 QUIT
KILL ;get rid of new clone if error
+1 SET DA=RMPRA
SET DIK=668
DO ^DIK
+2 QUIT
+3 ;END
