- RMPR29M ;PHX/JLT-E/MAIL FOR 2529-3 ACTION [4/14/95]
- ;;3.0;PROSTHETICS;;Feb 09, 1996
- CA21(RDA,PDA) ;CANCEL 2421 MESSAGE FOR ^RMPR(664.1,RDA) AND ^RMPR(664,PDA)
- ;CALLED FROM RMPR29C Cancel a 2529-3
- ;VARIABLES REQUIRED: RDA- ENTRY NUMBER IN FILE 664.1
- ; PDA - ENTRY NUMBER IN FILE 664
- ; RMPRWO - WORK ORDER
- ; SET: XMTEXT - TEXT FOR MAIL MESSAGE.
- Q:'$D(^RMPR(664.1,RDA,0))
- N RMPRWO,RMPRREF
- S RMPRWO=$P(^RMPR(664.1,RDA,0),U,13)
- ;rmprref is the reference number ot ifcap
- S RMPRREF=$P($G(^RMPR(664,PDA,0)),U,7)
- ;quit if the purchase has been cancelled or closed-out already
- I $D(^RMPR(664,PDA,0)),($P(^(0),8,0)!($P(^(0),U,5))) Q
- ;send message
- K XMY
- I RMPRREF'="" S XMSUB="Request to Cancel Prosthetics Purchase "_RMPRREF,RTX(1)="Work Order # "_RMPRWO_" has been Canceled.",RTX(2)="Please take action on "_RMPRREF_"."
- E S XMSUB="2421 Request for Work Order # "_RMPRWO_" has been Canceled",RTX(1)="2421 Request for Work Order # "_RMPRWO_" has been Canceled"
- S RTX(3)="BY: "_$$EMP^RMPR31U(DUZ)
- ;get cancellation remarks from the 2529-3
- F RT=0:0 S RT=$O(^RMPR(664.1,RDA,4,RT)) Q:RT'>0 I $D(^(RT,0)) S RTX(RT+3)=^(0)
- ;
- D ADM,SUP
- I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- ;
- IRQ ;SEND 2421 REQUEST NOTIFICATION
- Q:'$D(^RMPR(664.1,RMPRDA,0)) N RMPRWO S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) K XMY
- S XMSUB="2421 Request for Work Order # "_RMPRWO_" has been initiated",RTX(1)="2421 Request for Work Order # "_RMPRWO_" has been intiated"
- S RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- D ADM,SUP I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- ADM ;MAKE HOLDERS OF 'RMPR LAB ADMIN' KEY RECEIVER OF MESSAGE.
- F RT=0:0 S RT=$O(^XUSEC("RMPR LAB ADMIN",RT)) Q:RT'>0 S XMY(RT)=""
- Q
- SUP ;MAKE HOLDERS OF 'RMPR LAB SUPERVISOR' KEY RECEIVERS OF MESSAGE ALSO.
- F RT=0:0 S RT=$O(^XUSEC("RMPR LAB SUPERVISOR",RT)) Q:RT'>0 S XMY(RT)=""
- Q
- RTM ;RETURN 2529-3 TO LAB
- ;CALLED BY RMPR29C
- ;VARIABLES REQUIRED - RMPRDA ENTRY NUMBER IN FIRL 664.1
- N PEMP,RMPRWO S PEMP=$P(^RMPR(664.1,RMPRDA,0),U,16),RMPRWO=$P(^(0),U,13) I +PEMP>0 S XMY(PEMP)=""
- F RI=0:0 S RI=$O(^RMPR(664.1,RMPRDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) S RDA=^(0),RA=$P(RDA,U,5) D
- .F DA=0:0 S DA=$O(^RMPR(664.3,"C",RA,DA)) Q:DA'>0 I $D(^RMPR(664.3,DA)) F RU=0:0 S RU=$O(^RMPR(664.3,DA,1,RU)) Q:RU'>0 I $D(^(RU,0)) S PEMP=$P(^(0),U) I PEMP>0 S XMY(PEMP)=""
- S XMSUB="Work Order # "_RMPRWO_" Returned to Lab",RTX(1)=XMSUB,RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- F RR=0:0 S RR=$O(^RMPR(664.1,RMPRDA,6,RR)) Q:RR'>0 I $D(^(RR,0)) S RTX(RR+2)=^(0)
- D SUP I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- CA0(RDA,PDA) ;CANCEL 2421 OBLIGATION
- Q:'$D(^RMPR(664.1,RDA,0)) N RMPRWO,RMPRREF S RMPRWO=$P(^RMPR(664.1,RDA,0),U,13),RMPRREF=$P($G(^RMPR(664,PDA,0)),U,7) K XMY
- S XMSUB="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Canceled",RTX(1)="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Canceled"
- S RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- S PEMP=$P(^RMPR(664.1,RDA,0),U,16) I +PEMP>0 S XMY(PEMP)=""
- F RI=0:0 S RI=$O(^RMPR(664.1,RDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) S RDA=^(0),RA=$P(RDA,U,5) D
- .F DA=0:0 S DA=$O(^RMPR(664.3,"C",RA,DA)) Q:DA'>0 I $D(^RMPR(664.3,DA)) F RU=0:0 S RU=$O(^RMPR(664.3,DA,1,RU)) Q:RU'>0 I $D(^(RU,0)) S PEMP=$P(^(0),U) I PEMP>0 S XMY(PEMP)=""
- D SUP I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- DA0(RDA,PDA) ;DELIVER 2421
- Q:'$D(^RMPR(664.1,RDA,0)) N RMPRWO,RMPRREF S RMPRWO=$P(^RMPR(664.1,RDA,0),U,13),RMPRREF=$P($G(^RMPR(664,PDA,0)),U,7) K XMY
- S XMSUB="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Delivered"
- S RTX(1)="The 2421 Request "_RMPRREF_"has been closed out,"
- S RTX(2)="by "_$$EMP^RMPR31U(DUZ)_"."
- S RTX(3)=" "
- S RTX(4)="This is associated with Work Order # "_RMPRWO_","
- S RTX(5)="assigned to technician "_$P(^VA(200,$P(^RMPR(664.1,RDA,0),U,16),0),U,1)_"."
- S PEMP=$P(^RMPR(664.1,RDA,0),U,16) I +PEMP>0 S XMY(PEMP)=""
- F RI=0:0 S RI=$O(^RMPR(664.1,RDA,2,RI)) Q:RI'>0 I $D(^(RI,0)) S RDA=^(0),RA=$P(RDA,U,5) D
- .F DA=0:0 S DA=$O(^RMPR(664.3,"C",RA,DA)) Q:DA'>0 I $D(^RMPR(664.3,DA)) F RU=0:0 S RU=$O(^RMPR(664.3,DA,1,RU)) Q:RU'>0 I $D(^(RU,0)) S PEMP=$P(^(0),U) I PEMP>0 S XMY(PEMP)=""
- D SUP I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- DEL(PDA) ;DELETED 2421 REQUEST
- Q:('$D(^RMPR(664,PDA,0))) K XMY N RMPRWO S RMPRWO=$P($G(^RMPR(664.2,+$P(^(0),U,15),0)),U) I $P(^RMPR(664,PDA,0),U,16) S XMY($P(^(0),U,16))=""
- S DIE="^RMPR(664,",DA=RMPRA,DR="24" D ^DIE S XMSUB="2421 Request for Work Order # "_RMPRWO_" Has been Deleted",RTX(1)=XMSUB,RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- F RW=0:0 S RW=$O(^RMPR(664,PDA,4,RW)) Q:RW'>0 I $D(^(RW,0)) S RTX(RW+3)=^(0)
- D SUP I $D(XMY) S XMTEXT="RTX(" D ^XMD K XMY,RTX
- Q
- SLK ;SETUP DIC("S") FOR LABOR HOURS
- ;see internal notes
- ;CALLED FROM RMPR29B
- ;VARIABLES REQUIRED: + Y
- S DIC("S")="I $P(^RMPR(664.3,+Y,0),U,2)=DA660",DIC("W")="F ZI=0:0 S ZI=$O(^RMPR(664.3,+Y,1,ZI)) Q:+ZI'>0 I $D(^(ZI,0)) W ?40,$$EMP^RMPR31U($P(^(0),U)) I $O(^RMPR(664.3,+Y,1,ZI)) W !",DLAYGO=664.3,DIC="^RMPR(664.3,",DIC(0)="QML" Q
- Q
- PAP ;PURCHASE APPROVAL
- Q
- ;N RMPR90I
- ;D DIV4^RMPRSIT
- ;I '$D(^XUSEC("RMPRSUPERVISOR",DUZ)) Q
- ;S CNT=0 S RMPR90I=0 F S RMPR90I=$O(^RMPR(664,"AP",RMPR("STA"),RMPR90I)) Q:RMPR90I'>0 S CNT=CNT+1
- ;I +CNT W !!,?5,$C(7),"There "_$S(CNT>1:"are ",1:"is ")_CNT_" Purchase Request(s) Pending Approval"
- ;Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29M 5409 printed Jan 18, 2025@03:33:32 Page 2
- RMPR29M ;PHX/JLT-E/MAIL FOR 2529-3 ACTION [4/14/95]
- +1 ;;3.0;PROSTHETICS;;Feb 09, 1996
- CA21(RDA,PDA) ;CANCEL 2421 MESSAGE FOR ^RMPR(664.1,RDA) AND ^RMPR(664,PDA)
- +1 ;CALLED FROM RMPR29C Cancel a 2529-3
- +2 ;VARIABLES REQUIRED: RDA- ENTRY NUMBER IN FILE 664.1
- +3 ; PDA - ENTRY NUMBER IN FILE 664
- +4 ; RMPRWO - WORK ORDER
- +5 ; SET: XMTEXT - TEXT FOR MAIL MESSAGE.
- +6 if '$DATA(^RMPR(664.1,RDA,0))
- QUIT
- +7 NEW RMPRWO,RMPRREF
- +8 SET RMPRWO=$PIECE(^RMPR(664.1,RDA,0),U,13)
- +9 ;rmprref is the reference number ot ifcap
- +10 SET RMPRREF=$PIECE($GET(^RMPR(664,PDA,0)),U,7)
- +11 ;quit if the purchase has been cancelled or closed-out already
- +12 IF $DATA(^RMPR(664,PDA,0))
- IF ($PIECE(^(0),8,0)!($PIECE(^(0),U,5)))
- QUIT
- +13 ;send message
- +14 KILL XMY
- +15 IF RMPRREF'=""
- SET XMSUB="Request to Cancel Prosthetics Purchase "_RMPRREF
- SET RTX(1)="Work Order # "_RMPRWO_" has been Canceled."
- SET RTX(2)="Please take action on "_RMPRREF_"."
- +16 IF '$TEST
- SET XMSUB="2421 Request for Work Order # "_RMPRWO_" has been Canceled"
- SET RTX(1)="2421 Request for Work Order # "_RMPRWO_" has been Canceled"
- +17 SET RTX(3)="BY: "_$$EMP^RMPR31U(DUZ)
- +18 ;get cancellation remarks from the 2529-3
- +19 FOR RT=0:0
- SET RT=$ORDER(^RMPR(664.1,RDA,4,RT))
- if RT'>0
- QUIT
- IF $DATA(^(RT,0))
- SET RTX(RT+3)=^(0)
- +20 ;
- +21 DO ADM
- DO SUP
- +22 IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +23 QUIT
- +24 ;
- IRQ ;SEND 2421 REQUEST NOTIFICATION
- +1 if '$DATA(^RMPR(664.1,RMPRDA,0))
- QUIT
- NEW RMPRWO
- SET RMPRWO=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
- KILL XMY
- +2 SET XMSUB="2421 Request for Work Order # "_RMPRWO_" has been initiated"
- SET RTX(1)="2421 Request for Work Order # "_RMPRWO_" has been intiated"
- +3 SET RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- +4 DO ADM
- DO SUP
- IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +5 QUIT
- ADM ;MAKE HOLDERS OF 'RMPR LAB ADMIN' KEY RECEIVER OF MESSAGE.
- +1 FOR RT=0:0
- SET RT=$ORDER(^XUSEC("RMPR LAB ADMIN",RT))
- if RT'>0
- QUIT
- SET XMY(RT)=""
- +2 QUIT
- SUP ;MAKE HOLDERS OF 'RMPR LAB SUPERVISOR' KEY RECEIVERS OF MESSAGE ALSO.
- +1 FOR RT=0:0
- SET RT=$ORDER(^XUSEC("RMPR LAB SUPERVISOR",RT))
- if RT'>0
- QUIT
- SET XMY(RT)=""
- +2 QUIT
- RTM ;RETURN 2529-3 TO LAB
- +1 ;CALLED BY RMPR29C
- +2 ;VARIABLES REQUIRED - RMPRDA ENTRY NUMBER IN FIRL 664.1
- +3 NEW PEMP,RMPRWO
- SET PEMP=$PIECE(^RMPR(664.1,RMPRDA,0),U,16)
- SET RMPRWO=$PIECE(^(0),U,13)
- IF +PEMP>0
- SET XMY(PEMP)=""
- +4 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664.1,RMPRDA,2,RI))
- if RI'>0
- QUIT
- IF $DATA(^(RI,0))
- SET RDA=^(0)
- SET RA=$PIECE(RDA,U,5)
- Begin DoDot:1
- +5 FOR DA=0:0
- SET DA=$ORDER(^RMPR(664.3,"C",RA,DA))
- if DA'>0
- QUIT
- IF $DATA(^RMPR(664.3,DA))
- FOR RU=0:0
- SET RU=$ORDER(^RMPR(664.3,DA,1,RU))
- if RU'>0
- QUIT
- IF $DATA(^(RU,0))
- SET PEMP=$PIECE(^(0),U)
- IF PEMP>0
- SET XMY(PEMP)=""
- End DoDot:1
- +6 SET XMSUB="Work Order # "_RMPRWO_" Returned to Lab"
- SET RTX(1)=XMSUB
- SET RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- +7 FOR RR=0:0
- SET RR=$ORDER(^RMPR(664.1,RMPRDA,6,RR))
- if RR'>0
- QUIT
- IF $DATA(^(RR,0))
- SET RTX(RR+2)=^(0)
- +8 DO SUP
- IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +9 QUIT
- CA0(RDA,PDA) ;CANCEL 2421 OBLIGATION
- +1 if '$DATA(^RMPR(664.1,RDA,0))
- QUIT
- NEW RMPRWO,RMPRREF
- SET RMPRWO=$PIECE(^RMPR(664.1,RDA,0),U,13)
- SET RMPRREF=$PIECE($GET(^RMPR(664,PDA,0)),U,7)
- KILL XMY
- +2 SET XMSUB="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Canceled"
- SET RTX(1)="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Canceled"
- +3 SET RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- +4 SET PEMP=$PIECE(^RMPR(664.1,RDA,0),U,16)
- IF +PEMP>0
- SET XMY(PEMP)=""
- +5 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664.1,RDA,2,RI))
- if RI'>0
- QUIT
- IF $DATA(^(RI,0))
- SET RDA=^(0)
- SET RA=$PIECE(RDA,U,5)
- Begin DoDot:1
- +6 FOR DA=0:0
- SET DA=$ORDER(^RMPR(664.3,"C",RA,DA))
- if DA'>0
- QUIT
- IF $DATA(^RMPR(664.3,DA))
- FOR RU=0:0
- SET RU=$ORDER(^RMPR(664.3,DA,1,RU))
- if RU'>0
- QUIT
- IF $DATA(^(RU,0))
- SET PEMP=$PIECE(^(0),U)
- IF PEMP>0
- SET XMY(PEMP)=""
- End DoDot:1
- +7 DO SUP
- IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +8 QUIT
- DA0(RDA,PDA) ;DELIVER 2421
- +1 if '$DATA(^RMPR(664.1,RDA,0))
- QUIT
- NEW RMPRWO,RMPRREF
- SET RMPRWO=$PIECE(^RMPR(664.1,RDA,0),U,13)
- SET RMPRREF=$PIECE($GET(^RMPR(664,PDA,0)),U,7)
- KILL XMY
- +2 SET XMSUB="2421 Request "_RMPRREF_" for Work Order # "_RMPRWO_" has been Delivered"
- +3 SET RTX(1)="The 2421 Request "_RMPRREF_"has been closed out,"
- +4 SET RTX(2)="by "_$$EMP^RMPR31U(DUZ)_"."
- +5 SET RTX(3)=" "
- +6 SET RTX(4)="This is associated with Work Order # "_RMPRWO_","
- +7 SET RTX(5)="assigned to technician "_$PIECE(^VA(200,$PIECE(^RMPR(664.1,RDA,0),U,16),0),U,1)_"."
- +8 SET PEMP=$PIECE(^RMPR(664.1,RDA,0),U,16)
- IF +PEMP>0
- SET XMY(PEMP)=""
- +9 FOR RI=0:0
- SET RI=$ORDER(^RMPR(664.1,RDA,2,RI))
- if RI'>0
- QUIT
- IF $DATA(^(RI,0))
- SET RDA=^(0)
- SET RA=$PIECE(RDA,U,5)
- Begin DoDot:1
- +10 FOR DA=0:0
- SET DA=$ORDER(^RMPR(664.3,"C",RA,DA))
- if DA'>0
- QUIT
- IF $DATA(^RMPR(664.3,DA))
- FOR RU=0:0
- SET RU=$ORDER(^RMPR(664.3,DA,1,RU))
- if RU'>0
- QUIT
- IF $DATA(^(RU,0))
- SET PEMP=$PIECE(^(0),U)
- IF PEMP>0
- SET XMY(PEMP)=""
- End DoDot:1
- +11 DO SUP
- IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +12 QUIT
- DEL(PDA) ;DELETED 2421 REQUEST
- +1 if ('$DATA(^RMPR(664,PDA,0)))
- QUIT
- KILL XMY
- NEW RMPRWO
- SET RMPRWO=$PIECE($GET(^RMPR(664.2,+$PIECE(^(0),U,15),0)),U)
- IF $PIECE(^RMPR(664,PDA,0),U,16)
- SET XMY($PIECE(^(0),U,16))=""
- +2 SET DIE="^RMPR(664,"
- SET DA=RMPRA
- SET DR="24"
- DO ^DIE
- SET XMSUB="2421 Request for Work Order # "_RMPRWO_" Has been Deleted"
- SET RTX(1)=XMSUB
- SET RTX(2)="BY: "_$$EMP^RMPR31U(DUZ)
- +3 FOR RW=0:0
- SET RW=$ORDER(^RMPR(664,PDA,4,RW))
- if RW'>0
- QUIT
- IF $DATA(^(RW,0))
- SET RTX(RW+3)=^(0)
- +4 DO SUP
- IF $DATA(XMY)
- SET XMTEXT="RTX("
- DO ^XMD
- KILL XMY,RTX
- +5 QUIT
- SLK ;SETUP DIC("S") FOR LABOR HOURS
- +1 ;see internal notes
- +2 ;CALLED FROM RMPR29B
- +3 ;VARIABLES REQUIRED: + Y
- +4 SET DIC("S")="I $P(^RMPR(664.3,+Y,0),U,2)=DA660"
- SET DIC("W")="F ZI=0:0 S ZI=$O(^RMPR(664.3,+Y,1,ZI)) Q:+ZI'>0 I $D(^(ZI,0)) W ?40,$$EMP^RMPR31U($P(^(0),U)) I $O(^RMPR(664.3,+Y,1,ZI)) W !"
- SET DLAYGO=664.3
- SET DIC="^RMPR(664.3,"
- SET DIC(0)="QML"
- QUIT
- +5 QUIT
- PAP ;PURCHASE APPROVAL
- +1 QUIT
- +2 ;N RMPR90I
- +3 ;D DIV4^RMPRSIT
- +4 ;I '$D(^XUSEC("RMPRSUPERVISOR",DUZ)) Q
- +5 ;S CNT=0 S RMPR90I=0 F S RMPR90I=$O(^RMPR(664,"AP",RMPR("STA"),RMPR90I)) Q:RMPR90I'>0 S CNT=CNT+1
- +6 ;I +CNT W !!,?5,$C(7),"There "_$S(CNT>1:"are ",1:"is ")_CNT_" Purchase Request(s) Pending Approval"
- +7 ;Q