- RMPR29U ;PHX/JLT-2529-3 UTILITIES[ 11/28/94 3:55 PM ]
- ;;3.0;PROSTHETICS;**2,41,50,62**;Feb 09, 1996
- ;
- ; ODJ - patch 50 - 7/17/00 nois STL-0400-42007
- ; In POST subroutine ensure that if a 660 pointer
- ; in a 664.2 record points to non-existant 660 the
- ; routine does not crash.
- ; RVD patch #62 - PCE and suspense link.
- ;
- ST ;DISPLAY ASSIGNED WORK ORDER
- S DIE="^RMPR(664.1,",DA=RMPRDA,DR="27////^S X=DUZ;15////^S X=PEMP;16///A" D ^DIE
- ;W !!,?5,"Work Order Number: ",RMPRWO,!,?5,"Assigned to: ",$P($P(^VA(200,+PEMP,0),U,1),",",2)_" "_$P($P(^VA(200,+PEMP,0),U,1),",",1) Q
- Q
- INVD(INVP,IVIT) ;GET DEFAULTS FOR INVENTORY ITEM
- ;SEE DBA #698 ; CUSTODIAL PACKAGE - IFCAP ;CUSTODIAL ISC - WASHINGTON
- N DIC,Y,DA S DIC="^PRCP(445,"_INVP_",1,",DA(1)=INVP,DIC(0)="MNZ",X=IVIT D ^DIC I +Y'>0 S (VEN,COST)="" Q
- S VEN=$S($G(VEN)="":$P(Y(0),U,12),1:VEN),COST=$P(Y(0),U,15) I +VEN,$D(^PRC(440,+VEN,0)) S VEN=$P(^(0),U,1)
- Q
- ITV(VEN,ITM) ;GET DEFAULT VENDOR FOR ITEM
- ;SEE DBA #801 ; CUSTODIAL PACKAGE - IFCAP ; CUSTODIAL ISC - WASHINGTON
- N DIC,Y S VEN=$S($P(^PRC(441,ITM,0),U,8):$P(^(0),U,8),1:$O(^PRC(441,ITM,2,"B",0))) I 'VEN S VDR="" Q
- S DIC="^PRC(441,"_ITM_",2,",DA(1)=ITM,DIC(0)="MNZ",X=VEN D ^DIC I +Y>0 S VDR=Y(0,0)
- E S VDR=""
- Q
- ITC(VEN,ITM) ;DEFAULT COST FOR ITEM
- ;SEE DBA # 801 ; CUSTODIAL PACKAGE - IFCAP ; CUSTODIAL ISC - WASHINGTON
- N DIC,Y I VEN="" S VEN=$S($P(^PRC(441,ITM,0),U,8):$P(^(0),U,8),1:$O(^PRC(441,ITM,2,"B",0))) I 'VEN S COST="" Q
- S DIC="^PRC(441,"_ITM_",2,",DA(1)=ITM,DIC(0)="MNZ",X=VEN D ^DIC I +Y>0 S COST=$P(Y(0),U,2)
- E S COST=""
- Q
- POST ;POST JOB SECTION TO 2319
- S (TCST,THRS,TLCST,CST,HRS,LCST,RHR,RLM)=0,DA660=+$P(^RMPR(664.2,RMPRWO,0),U,2),RWK=$P(^(0),U),RMPRSH=$S($P(^(0),U,7):$P(^(0),U,7),1:$P(^(0),U,6)),RMPRCD=$P(^RMPR(664.2,RMPRWO,0),U,10)
- ;added by #62
- I $G(DA660),'$D(^RMPR(660,DA660,10)) D
- .S (RMPCAMIS,RMPRDFN)=""
- .S RMPCAMIS=$G(^RMPR(660,DA660,"AMS"))
- .S:$D(^RMPR(660,DA660,0)) RMPRDFN=$P(^RMPR(660,DA660,0),U,2)
- .I RMPCAMIS,RMPRDFN S ^TMP($J,"RMPRPCE",660,DA660)=RMPCAMIS_"^"_RMPRDFN
- F RI=0:0 S RI=$O(^RMPR(664.2,RMPRWO,1,RI)) Q:RI'>0 I $D(^(RI,0)) S CST=$P(^(0),U,3),QTY=$P(^(0),U,2) S CST=$J(CST*QTY,0,2),TCST=TCST+CST
- F RI=0:0 S RI=$O(^RMPR(664.3,"C",DA660,RI)) Q:RI'>0 I $D(^RMPR(664.3,RI,0)) F RT=0:0 S RT=$O(^RMPR(664.3,RI,1,RT)) Q:RT'>0 D
- .S HRS=$P(^RMPR(664.3,RI,1,RT,0),U,2),LCST=$P(^(0),U,3),LCST=$J(HRS*LCST,0,2),TLCST=TLCST+LCST,RHR=RHR+$P(HRS,"."),RLM=RLM+$P(HRS,".",2)
- .S THRS=THRS+HRS
- ;
- ; p50 - if 660 record does not exist permit LB section to be created
- ; in case need to refer to costs of work done on canceled requests
- S $P(^RMPR(660,DA660,"LB"),U,6)=THRS,$P(^("LB"),U,7)=$J(TLCST,0,2),$P(^("LB"),U,8)=$J(TCST+RMPRSH,0,2),$P(^("LB"),U,9)=$J(TLCST+TCST+RMPRSH,0,2)
- S $P(^RMPR(660,DA660,"LB"),U,11)=RMPRCD
- ;
- ; p50 - only update 660 0rec if already exists (ie not canceled)
- I DA660,$D(^RMPR(660,DA660,0)) D
- . S RDEL=$P(^RMPR(660,DA660,0),U,12),$P(^(0),U,12)=RMPRCD
- . K:RDEL ^RMPR(660,"CT",RDEL,DA660),^RMPR(660,"CD",RDEL,DA660)
- . I RMPRCD S DA=DA660,DIE="^RMPR(660,",DR="83///@" D ^DIE
- . S DA=DA660,DIK="^RMPR(660," D IX^DIK
- . Q
- S RMPRDA=$O(^RMPR(664.1,"C",RWK,0)),DA=$O(^RMPR(664.1,"AC",RMPRDA,DA660,0)) I +DA S $P(^RMPR(664.1,RMPRDA,2,DA,0),U,4)=$J(TCST+RMPRSH,0,2),$P(^(0),U,11)=$J(TLCST+TCST+RMPRSH,0,2)
- Q
- EN4(RDA) ;CREATE JOB RECORD
- S RMPR("REF")=$P(^RMPR(664.1,RDA,0),U,4),$P(^(0),U,20)="",RN=+$P(^(0),U,24)
- K DIC,Y F RT=0:0 S RT=$O(^RMPR(664.1,RDA,2,RT)) Q:RT'>0 I $D(^(RT,0)) S DA660=$P(^(0),U,5) I +DA660,'$D(^RMPR(664.2,"C",DA660)) D S $P(^RMPR(664.1,RDA,0),U,24)=RN
- .K DA,D0,DD,DO S DIC="^RMPR(664.2,",DIC(0)="LZ",X=$P(^RMPR(664.1,RDA,0),U,13) D FILE^DICN Q:+Y'>0
- .S RN=RN+1,$P(^RMPR(664.2,+Y,0),U,2)=DA660,$P(^(0),U,3)=RMPR("STA"),$P(^(0),U,4)=RN,$P(^(0),U,8)=RMPR("REF") S DA=+Y,DIK="^RMPR(664.2," D IX1^DIK I $D(^RMPR(660,DA660,0)) D
- ..S $P(^RMPR(660,DA660,"LB"),U,5)=DA,$P(^RMPR(664.1,RDA,2,RT,0),U,6)=DA,DA=DA660,DIE="^RMPR(660,",DR="83///^S X=$P(^RMPR(664.1,RDA,0),U,1)" D ^DIE
- Q
- CR(SCR) ;CREATE WORK ORDER
- N DIC,Y,DIR S RMPRWO=1 D FQ^RMPRDT Q:'$D(RMPRFY)!('$D(RMPRQTR)) S:'$D(RMPRTMP) RMPRWO=$$STAN^RMPR31U(RMPR("STA"))_"-"_RMPRFY_"-"_RMPRQTR I $D(RMPRTMP) D
- .S RMPRWO=$$STAN^RMPR31U($P(^RMPR(664.1,RMPRDA,0),U,15))_"T-"_RMPRFY_"-"_RMPRQTR
- I '$D(^RMPR(669.1,"B",RMPRWO)) S DIC="^RMPR(669.1,",DLAYGO=669.1,DIC(0)="LZ",X=RMPRWO D FILE^DICN K DLAYGO
- S RDA=$O(^RMPR(669.1,"B",RMPRWO,0)) Q:'RDA
- L +^RMPR(669.1,RDA,0):1 I '$T W !!,$C(7),"Someone is editing this record!" G EXIT
- S RN=$P(^RMPR(669.1,RDA,0),U,2)+1 F I=1:1:4-$L(RN) S RN="0"_RN
- S RMPRWO=RMPRWO_"-"_SCR_"-"_RN
- S $P(^RMPR(669.1,RDA,0),U,2)=RN L -^RMPR(669.1,RDA,0) Q
- ITA(RY) ;CHK FOR AMIS CODE PASS Y AND RMPRDA
- Q:'$D(RMPRDA) Q:$P($G(^RMPR(664.1,RMPRDA,0)),U,15)'=RMPR("STA") N Y,X,DIC,DR,DIE,DA,DIRUT,DTOUT,SCR K FLA
- S SCR=$P(^RMPR(664.1,RMPRDA,0),U,11) S DR=$S(SCR'="R":"1;2;3;4",1:"1;2;5;6") I SCR="W" S DR="1;2;4"
- I SCR'="R",'$P(^RMPR(661,RY,0),U,5),('$P(^(0),U,6)) W !!,$C(7),"Orthotic Lab AMIS Codes have not been entered for this item" S FLA=1
- I SCR="R",'$P(^RMPR(661,RY,0),U,7),('$P(^(0),U,8)) W !!,$C(7),?5,"Restoration AMIS Codes have not been entered for this item" S FLA=1
- I $D(FLA) S DIR(0)="Y",DIR("A")="Would You like to enter them now",DIR("B")="Y" D ^DIR Q:$D(DIRUT)!($D(DTOUT))!(+Y'>0) K Y,X S DA=RY,DIE="^RMPR(661," D ^DIE
- K FLA Q
- PAID(EMP) ;GET PAID LABOR HOURS
- ;CALLED BY RMPR29B
- ;VARIABLES REQUIRED: EMP - ENTRY NUMBER FOR EMPLOYEE IN FILE 200
- ;VARIABLE SET : RMPR450 - GET HOURLY WAGE RATE.
- ;this call is no longer being used, trying to clean up!
- Q 0
- ; REWRITE ACCORDING TO SAC
- AUL ;check for lab or clinic
- ;this input transform is no longer going to be supported, remove
- ;by version 4.
- ;
- ;I '$D(RMPR)!('$D(RMPRSITE)) K X Q
- ;I X'=RMPR("STA") W !!,?5,$C(7),"VAF 10-2529-3 request cannot be processed locally" K X Q
- ;I '$P($G(^RMPR(669.9,$G(RMPRSITE),0)),U,6) W !!,?5,$C(7),"You cannot process VAF 10-2529-3 work orders." K X Q
- Q
- EXIT N RMPR,RMPRSITE K ^TMP($J,"RMPRPCE") D KILL^XUSCLEAN Q
- CHKCPT(RDATA) ;check for cpt modifier - change of Type of Transaction.
- N RMHCPC,RMCPT,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- S RMTYPE=$P(RDATA,U,1),RMPRA=$P(RDATA,U,2),R4DA=$P(RDATA,U,3)
- S RMHCPC=$P($G(^RMPR(664.1,RMPRA,2,R4DA,2)),U,1)
- S RMCPT=$P($G(^RMPR(664.1,RMPRA,2,R4DA,2)),U,2) Q:'$G(RMHCPC)
- I ((RMTYPE="R")!(RMTYPE="X")),(RMCPT'["RP"),($G(^RMPR(661.1,RMHCPC,4))["RP") D ADDRP
- I ((RMTYPE="I")!(RMTYPE="S")),(RMCPT["RP") D DELRP
- K RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA Q
- ;return to (-3) ADD/EDIT option
- DELRP ;logic for deleting 'RP' modifier with transaction change.
- F RMCI=1:1:8 S RMC=$P(RMCPT,",",RMCI) I RMC="RP" S $P(RMCPT,",",RMCI)="" D
- .S RMF=$F(RMCPT,",,"),RMFPIECE=$E(RMCPT,1,RMF-2)
- .S RMLPIECE=$E(RMCPT,RMF,32),RMCPT=RMFPIECE_RMLPIECE,RMCLEN=$L(RMCPT)
- .I $E(RMCPT,1)="," S RMCPT=$E(RMCPT,2,RMCLEN)
- .I $E(RMCPT,RMCLEN)="," S RMCPT=$E(RMCPT,1,RMCLEN-1)
- .S $P(^RMPR(664.1,RMPRA,2,R4DA,2),U,2)=RMCPT
- Q
- ;
- ADDRP ;logic for adding 'RP' modifier with transaction change.
- S RMCPT=RMCPT_",RP" S $P(^RMPR(664.1,RMPRA,2,R4DA,2),U,2)=RMCPT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29U 7301 printed Feb 18, 2025@23:58:58 Page 2
- RMPR29U ;PHX/JLT-2529-3 UTILITIES[ 11/28/94 3:55 PM ]
- +1 ;;3.0;PROSTHETICS;**2,41,50,62**;Feb 09, 1996
- +2 ;
- +3 ; ODJ - patch 50 - 7/17/00 nois STL-0400-42007
- +4 ; In POST subroutine ensure that if a 660 pointer
- +5 ; in a 664.2 record points to non-existant 660 the
- +6 ; routine does not crash.
- +7 ; RVD patch #62 - PCE and suspense link.
- +8 ;
- ST ;DISPLAY ASSIGNED WORK ORDER
- +1 SET DIE="^RMPR(664.1,"
- SET DA=RMPRDA
- SET DR="27////^S X=DUZ;15////^S X=PEMP;16///A"
- DO ^DIE
- +2 ;W !!,?5,"Work Order Number: ",RMPRWO,!,?5,"Assigned to: ",$P($P(^VA(200,+PEMP,0),U,1),",",2)_" "_$P($P(^VA(200,+PEMP,0),U,1),",",1) Q
- +3 QUIT
- INVD(INVP,IVIT) ;GET DEFAULTS FOR INVENTORY ITEM
- +1 ;SEE DBA #698 ; CUSTODIAL PACKAGE - IFCAP ;CUSTODIAL ISC - WASHINGTON
- +2 NEW DIC,Y,DA
- SET DIC="^PRCP(445,"_INVP_",1,"
- SET DA(1)=INVP
- SET DIC(0)="MNZ"
- SET X=IVIT
- DO ^DIC
- IF +Y'>0
- SET (VEN,COST)=""
- QUIT
- +3 SET VEN=$SELECT($GET(VEN)="":$PIECE(Y(0),U,12),1:VEN)
- SET COST=$PIECE(Y(0),U,15)
- IF +VEN
- IF $DATA(^PRC(440,+VEN,0))
- SET VEN=$PIECE(^(0),U,1)
- +4 QUIT
- ITV(VEN,ITM) ;GET DEFAULT VENDOR FOR ITEM
- +1 ;SEE DBA #801 ; CUSTODIAL PACKAGE - IFCAP ; CUSTODIAL ISC - WASHINGTON
- +2 NEW DIC,Y
- SET VEN=$SELECT($PIECE(^PRC(441,ITM,0),U,8):$PIECE(^(0),U,8),1:$ORDER(^PRC(441,ITM,2,"B",0)))
- IF 'VEN
- SET VDR=""
- QUIT
- +3 SET DIC="^PRC(441,"_ITM_",2,"
- SET DA(1)=ITM
- SET DIC(0)="MNZ"
- SET X=VEN
- DO ^DIC
- IF +Y>0
- SET VDR=Y(0,0)
- +4 IF '$TEST
- SET VDR=""
- +5 QUIT
- ITC(VEN,ITM) ;DEFAULT COST FOR ITEM
- +1 ;SEE DBA # 801 ; CUSTODIAL PACKAGE - IFCAP ; CUSTODIAL ISC - WASHINGTON
- +2 NEW DIC,Y
- IF VEN=""
- SET VEN=$SELECT($PIECE(^PRC(441,ITM,0),U,8):$PIECE(^(0),U,8),1:$ORDER(^PRC(441,ITM,2,"B",0)))
- IF 'VEN
- SET COST=""
- QUIT
- +3 SET DIC="^PRC(441,"_ITM_",2,"
- SET DA(1)=ITM
- SET DIC(0)="MNZ"
- SET X=VEN
- DO ^DIC
- IF +Y>0
- SET COST=$PIECE(Y(0),U,2)
- +4 IF '$TEST
- SET COST=""
- +5 QUIT
- POST ;POST JOB SECTION TO 2319
- +1 SET (TCST,THRS,TLCST,CST,HRS,LCST,RHR,RLM)=0
- SET DA660=+$PIECE(^RMPR(664.2,RMPRWO,0),U,2)
- SET RWK=$PIECE(^(0),U)
- SET RMPRSH=$SELECT($PIECE(^(0),U,7):$PIECE(^(0),U,7),1:$PIECE(^(0),U,6))
- SET RMPRCD=$PIECE(^RMPR(664.2,RMPRWO,0),U,10)
- +2 ;added by #62
- +3 IF $GET(DA660)
- IF '$DATA(^RMPR(660,DA660,10))
- Begin DoDot:1
- +4 SET (RMPCAMIS,RMPRDFN)=""
- +5 SET RMPCAMIS=$GET(^RMPR(660,DA660,"AMS"))
- +6 if $DATA(^RMPR(660,DA660,0))
- SET RMPRDFN=$PIECE(^RMPR(660,DA660,0),U,2)
- +7 IF RMPCAMIS
- IF RMPRDFN
- SET ^TMP($JOB,"RMPRPCE",660,DA660)=RMPCAMIS_"^"_RMPRDFN
- End DoDot:1
- +8 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664.2,RMPRWO,1,RI))
- if RI'>0
- QUIT
- IF $DATA(^(RI,0))
- SET CST=$PIECE(^(0),U,3)
- SET QTY=$PIECE(^(0),U,2)
- SET CST=$JUSTIFY(CST*QTY,0,2)
- SET TCST=TCST+CST
- +9 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664.3,"C",DA660,RI))
- if RI'>0
- QUIT
- IF $DATA(^RMPR(664.3,RI,0))
- FOR RT=0:0
- SET RT=$ORDER(^RMPR(664.3,RI,1,RT))
- if RT'>0
- QUIT
- Begin DoDot:1
- +10 SET HRS=$PIECE(^RMPR(664.3,RI,1,RT,0),U,2)
- SET LCST=$PIECE(^(0),U,3)
- SET LCST=$JUSTIFY(HRS*LCST,0,2)
- SET TLCST=TLCST+LCST
- SET RHR=RHR+$PIECE(HRS,".")
- SET RLM=RLM+$PIECE(HRS,".",2)
- +11 SET THRS=THRS+HRS
- End DoDot:1
- +12 ;
- +13 ; p50 - if 660 record does not exist permit LB section to be created
- +14 ; in case need to refer to costs of work done on canceled requests
- +15 SET $PIECE(^RMPR(660,DA660,"LB"),U,6)=THRS
- SET $PIECE(^("LB"),U,7)=$JUSTIFY(TLCST,0,2)
- SET $PIECE(^("LB"),U,8)=$JUSTIFY(TCST+RMPRSH,0,2)
- SET $PIECE(^("LB"),U,9)=$JUSTIFY(TLCST+TCST+RMPRSH,0,2)
- +16 SET $PIECE(^RMPR(660,DA660,"LB"),U,11)=RMPRCD
- +17 ;
- +18 ; p50 - only update 660 0rec if already exists (ie not canceled)
- +19 IF DA660
- IF $DATA(^RMPR(660,DA660,0))
- Begin DoDot:1
- +20 SET RDEL=$PIECE(^RMPR(660,DA660,0),U,12)
- SET $PIECE(^(0),U,12)=RMPRCD
- +21 if RDEL
- KILL ^RMPR(660,"CT",RDEL,DA660),^RMPR(660,"CD",RDEL,DA660)
- +22 IF RMPRCD
- SET DA=DA660
- SET DIE="^RMPR(660,"
- SET DR="83///@"
- DO ^DIE
- +23 SET DA=DA660
- SET DIK="^RMPR(660,"
- DO IX^DIK
- +24 QUIT
- End DoDot:1
- +25 SET RMPRDA=$ORDER(^RMPR(664.1,"C",RWK,0))
- SET DA=$ORDER(^RMPR(664.1,"AC",RMPRDA,DA660,0))
- IF +DA
- SET $PIECE(^RMPR(664.1,RMPRDA,2,DA,0),U,4)=$JUSTIFY(TCST+RMPRSH,0,2)
- SET $PIECE(^(0),U,11)=$JUSTIFY(TLCST+TCST+RMPRSH,0,2)
- +26 QUIT
- EN4(RDA) ;CREATE JOB RECORD
- +1 SET RMPR("REF")=$PIECE(^RMPR(664.1,RDA,0),U,4)
- SET $PIECE(^(0),U,20)=""
- SET RN=+$PIECE(^(0),U,24)
- +2 KILL DIC,Y
- FOR RT=0:0
- SET RT=$ORDER(^RMPR(664.1,RDA,2,RT))
- if RT'>0
- QUIT
- IF $DATA(^(RT,0))
- SET DA660=$PIECE(^(0),U,5)
- IF +DA660
- IF '$DATA(^RMPR(664.2,"C",DA660))
- Begin DoDot:1
- +3 KILL DA,D0,DD,DO
- SET DIC="^RMPR(664.2,"
- SET DIC(0)="LZ"
- SET X=$PIECE(^RMPR(664.1,RDA,0),U,13)
- DO FILE^DICN
- if +Y'>0
- QUIT
- +4 SET RN=RN+1
- SET $PIECE(^RMPR(664.2,+Y,0),U,2)=DA660
- SET $PIECE(^(0),U,3)=RMPR("STA")
- SET $PIECE(^(0),U,4)=RN
- SET $PIECE(^(0),U,8)=RMPR("REF")
- SET DA=+Y
- SET DIK="^RMPR(664.2,"
- DO IX1^DIK
- IF $DATA(^RMPR(660,DA660,0))
- Begin DoDot:2
- +5 SET $PIECE(^RMPR(660,DA660,"LB"),U,5)=DA
- SET $PIECE(^RMPR(664.1,RDA,2,RT,0),U,6)=DA
- SET DA=DA660
- SET DIE="^RMPR(660,"
- SET DR="83///^S X=$P(^RMPR(664.1,RDA,0),U,1)"
- DO ^DIE
- End DoDot:2
- End DoDot:1
- SET $PIECE(^RMPR(664.1,RDA,0),U,24)=RN
- +6 QUIT
- CR(SCR) ;CREATE WORK ORDER
- +1 NEW DIC,Y,DIR
- SET RMPRWO=1
- DO FQ^RMPRDT
- if '$DATA(RMPRFY)!('$DATA(RMPRQTR))
- QUIT
- if '$DATA(RMPRTMP)
- SET RMPRWO=$$STAN^RMPR31U(RMPR("STA"))_"-"_RMPRFY_"-"_RMPRQTR
- IF $DATA(RMPRTMP)
- Begin DoDot:1
- +2 SET RMPRWO=$$STAN^RMPR31U($PIECE(^RMPR(664.1,RMPRDA,0),U,15))_"T-"_RMPRFY_"-"_RMPRQTR
- End DoDot:1
- +3 IF '$DATA(^RMPR(669.1,"B",RMPRWO))
- SET DIC="^RMPR(669.1,"
- SET DLAYGO=669.1
- SET DIC(0)="LZ"
- SET X=RMPRWO
- DO FILE^DICN
- KILL DLAYGO
- +4 SET RDA=$ORDER(^RMPR(669.1,"B",RMPRWO,0))
- if 'RDA
- QUIT
- +5 LOCK +^RMPR(669.1,RDA,0):1
- IF '$TEST
- WRITE !!,$CHAR(7),"Someone is editing this record!"
- GOTO EXIT
- +6 SET RN=$PIECE(^RMPR(669.1,RDA,0),U,2)+1
- FOR I=1:1:4-$LENGTH(RN)
- SET RN="0"_RN
- +7 SET RMPRWO=RMPRWO_"-"_SCR_"-"_RN
- +8 SET $PIECE(^RMPR(669.1,RDA,0),U,2)=RN
- LOCK -^RMPR(669.1,RDA,0)
- QUIT
- ITA(RY) ;CHK FOR AMIS CODE PASS Y AND RMPRDA
- +1 if '$DATA(RMPRDA)
- QUIT
- if $PIECE($GET(^RMPR(664.1,RMPRDA,0)),U,15)'=RMPR("STA")
- QUIT
- NEW Y,X,DIC,DR,DIE,DA,DIRUT,DTOUT,SCR
- KILL FLA
- +2 SET SCR=$PIECE(^RMPR(664.1,RMPRDA,0),U,11)
- SET DR=$SELECT(SCR'="R":"1;2;3;4",1:"1;2;5;6")
- IF SCR="W"
- SET DR="1;2;4"
- +3 IF SCR'="R"
- IF '$PIECE(^RMPR(661,RY,0),U,5)
- IF ('$PIECE(^(0),U,6))
- WRITE !!,$CHAR(7),"Orthotic Lab AMIS Codes have not been entered for this item"
- SET FLA=1
- +4 IF SCR="R"
- IF '$PIECE(^RMPR(661,RY,0),U,7)
- IF ('$PIECE(^(0),U,8))
- WRITE !!,$CHAR(7),?5,"Restoration AMIS Codes have not been entered for this item"
- SET FLA=1
- +5 IF $DATA(FLA)
- SET DIR(0)="Y"
- SET DIR("A")="Would You like to enter them now"
- SET DIR("B")="Y"
- DO ^DIR
- if $DATA(DIRUT)!($DATA(DTOUT))!(+Y'>0)
- QUIT
- KILL Y,X
- SET DA=RY
- SET DIE="^RMPR(661,"
- DO ^DIE
- +6 KILL FLA
- QUIT
- PAID(EMP) ;GET PAID LABOR HOURS
- +1 ;CALLED BY RMPR29B
- +2 ;VARIABLES REQUIRED: EMP - ENTRY NUMBER FOR EMPLOYEE IN FILE 200
- +3 ;VARIABLE SET : RMPR450 - GET HOURLY WAGE RATE.
- +4 ;this call is no longer being used, trying to clean up!
- +5 QUIT 0
- +6 ; REWRITE ACCORDING TO SAC
- AUL ;check for lab or clinic
- +1 ;this input transform is no longer going to be supported, remove
- +2 ;by version 4.
- +3 ;
- +4 ;I '$D(RMPR)!('$D(RMPRSITE)) K X Q
- +5 ;I X'=RMPR("STA") W !!,?5,$C(7),"VAF 10-2529-3 request cannot be processed locally" K X Q
- +6 ;I '$P($G(^RMPR(669.9,$G(RMPRSITE),0)),U,6) W !!,?5,$C(7),"You cannot process VAF 10-2529-3 work orders." K X Q
- +7 QUIT
- EXIT NEW RMPR,RMPRSITE
- KILL ^TMP($JOB,"RMPRPCE")
- DO KILL^XUSCLEAN
- QUIT
- CHKCPT(RDATA) ;check for cpt modifier - change of Type of Transaction.
- +1 NEW RMHCPC,RMCPT,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- +2 SET RMTYPE=$PIECE(RDATA,U,1)
- SET RMPRA=$PIECE(RDATA,U,2)
- SET R4DA=$PIECE(RDATA,U,3)
- +3 SET RMHCPC=$PIECE($GET(^RMPR(664.1,RMPRA,2,R4DA,2)),U,1)
- +4 SET RMCPT=$PIECE($GET(^RMPR(664.1,RMPRA,2,R4DA,2)),U,2)
- if '$GET(RMHCPC)
- QUIT
- +5 IF ((RMTYPE="R")!(RMTYPE="X"))
- IF (RMCPT'["RP")
- IF ($GET(^RMPR(661.1,RMHCPC,4))["RP")
- DO ADDRP
- +6 IF ((RMTYPE="I")!(RMTYPE="S"))
- IF (RMCPT["RP")
- DO DELRP
- +7 KILL RMHCPC,RMCI,RMC,RMCLEN,RMLPIECE,RMF,RMFPIECE,RMTYPE,RMPRA,R4DA
- QUIT
- +8 ;return to (-3) ADD/EDIT option
- DELRP ;logic for deleting 'RP' modifier with transaction change.
- +1 FOR RMCI=1:1:8
- SET RMC=$PIECE(RMCPT,",",RMCI)
- IF RMC="RP"
- SET $PIECE(RMCPT,",",RMCI)=""
- Begin DoDot:1
- +2 SET RMF=$FIND(RMCPT,",,")
- SET RMFPIECE=$EXTRACT(RMCPT,1,RMF-2)
- +3 SET RMLPIECE=$EXTRACT(RMCPT,RMF,32)
- SET RMCPT=RMFPIECE_RMLPIECE
- SET RMCLEN=$LENGTH(RMCPT)
- +4 IF $EXTRACT(RMCPT,1)=","
- SET RMCPT=$EXTRACT(RMCPT,2,RMCLEN)
- +5 IF $EXTRACT(RMCPT,RMCLEN)=","
- SET RMCPT=$EXTRACT(RMCPT,1,RMCLEN-1)
- +6 SET $PIECE(^RMPR(664.1,RMPRA,2,R4DA,2),U,2)=RMCPT
- End DoDot:1
- +7 QUIT
- +8 ;
- ADDRP ;logic for adding 'RP' modifier with transaction change.
- +1 SET RMCPT=RMCPT_",RP"
- SET $PIECE(^RMPR(664.1,RMPRA,2,R4DA,2),U,2)=RMCPT
- +2 QUIT