- PRCNCMRP ;SSI/SEB,ALA-CMR Official Priority Handler ;[ 01/23/97 4:52 PM ]
- ;;1.0;Equipment/Turn-In Request;**2,5**;Sep 13, 1996
- Q
- EN ;Check on entered priority
- K:+X'=X!(X>999)!(X<1)!(X?.E1"."1N.N) X
- I $G(X)="" Q
- ; Check if priority X already exists for this service
- D:'$D(PSER) PRIMAX
- S PRCNX=$P($G(^PRCN(413,DA,2)),U,18)
- I PRCNX'="" K ^PRCN(413,"P",PSER,PRCNX,DA)
- K PRCNX
- Q:'$D(^PRCN(413,"P",PSER,X))
- Q:$D(^PRCN(413,"P",PSER,X,DA))
- NEW I
- I $D(^PRCN(413,"P",PSER,X)) S START=X D DOWN S DA=ORGDA
- K START,ORGDA
- Q
- DOWN ; Insert this transaction & shift others one priority #
- W !!,"Reprioritizing this CMR's requests... Hold on..."
- D PRIMAX S LPRI=LPRI+1 S ORGDA=DA NEW DA S DA=ORGDA
- S ^PRCN(413,"P",PSER,START,ORGDA)=""
- S NXPR=START D GETDA
- I OTHDA'="",OTHDA'=DA S NXPR=START D GETPR
- K OTHDA,DA,NXPR,START,OLDA
- Q
- XREF ; Special MUMPS cross-reference for priorities
- S PRCNX=$G(X)
- S X=$P($G(^PRCN(413,DA,2)),U,18)
- D:'$D(PSER) PRIMAX
- I X="",$G(PRCNX)'="" K ^PRCN(413,"P",PSER,PRCNX,DA),PRCNX Q
- XR S STAT=$P(^PRCN(413,DA,0),U,7),SK=0
- I STAT<5!(STAT>10) S SK=1
- I STAT=31!(STAT=45)!(STAT=3)!(STAT=27) S SK=0
- I SK=0 S ^PRCN(413,"P",PSER,X,DA)=""
- I SK=1 K ^PRCN(413,"P",PSER,X,DA)
- K PSER,SK,STAT
- Q
- PRIMAX ; Calculate lowest priority. Used in input template, etc.
- ; Returns OLDPRI, PSER, SERV, LPRI, and PRIMAX.
- S OLDPRI=$P($G(^PRCN(413,DA,2)),U,18),PSER=$P($G(^PRCN(413,DA,0)),U,3)
- S (II,PRIMAX)=0 S:PSER'="" SERV=$P(^DIC(49,PSER,0),U)
- I PSER'="" F S II=$O(^PRCN(413,"P",PSER,II)) Q:II="" S PRIMAX=PRIMAX+1,LPRI=II
- I +OLDPRI'=0 S PRIMAX=+OLDPRI Q
- I +OLDPRI=0,$G(LPRI)="" S (PRIMAX,LPRI)=0 Q
- I +OLDPRI=0,$G(LPRI)'="" S PRIMAX=LPRI
- K II
- Q
- DPRI ; Display priorities. Called as special help for priority fld.
- I $G(SERV)=""!($G(PSER)="") D PRIMAX
- W !!,"Priority list for ",SERV,":"
- S PRCNI=0 F S PRCNI=$O(^PRCN(413,"P",PSER,PRCNI)) Q:'+PRCNI D
- . S J=$O(^PRCN(413,"P",PSER,PRCNI,""))
- . I $G(^PRCN(413,J,0))="" K ^PRCN(413,"P",PSER,PRCNI,J) Q
- . W !,PRCNI,?8,$P(^PRCN(413,J,0),U),?25,$P(^(0),U,18)
- K PRCNI,J
- Q
- GETPR S NXPR=$O(^PRCN(413,"P",PSER,NXPR))
- I NXPR'=(START+1) S NXPR=START+1 D SETDA Q
- I NXPR=(START+1) D SETDA S START=NXPR,DA=OTHDA D GETDA G GETPR
- Q
- SETDA S $P(^PRCN(413,OTHDA,2),U,18)=NXPR,^PRCN(413,"P",PSER,NXPR,OTHDA)=""
- K ^PRCN(413,"P",PSER,START,OTHDA)
- Q
- GETDA S OLDA="" F S OLDA=$O(^PRCN(413,"P",PSER,NXPR,OLDA)) Q:OLDA="" S:OLDA'=DA OTHDA=OLDA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNCMRP 2472 printed Apr 23, 2025@18:08:40 Page 2
- PRCNCMRP ;SSI/SEB,ALA-CMR Official Priority Handler ;[ 01/23/97 4:52 PM ]
- +1 ;;1.0;Equipment/Turn-In Request;**2,5**;Sep 13, 1996
- +2 QUIT
- EN ;Check on entered priority
- +1 if +X'=X!(X>999)!(X<1)!(X?.E1"."1N.N)
- KILL X
- +2 IF $GET(X)=""
- QUIT
- +3 ; Check if priority X already exists for this service
- +4 if '$DATA(PSER)
- DO PRIMAX
- +5 SET PRCNX=$PIECE($GET(^PRCN(413,DA,2)),U,18)
- +6 IF PRCNX'=""
- KILL ^PRCN(413,"P",PSER,PRCNX,DA)
- +7 KILL PRCNX
- +8 if '$DATA(^PRCN(413,"P",PSER,X))
- QUIT
- +9 if $DATA(^PRCN(413,"P",PSER,X,DA))
- QUIT
- +10 NEW I
- +11 IF $DATA(^PRCN(413,"P",PSER,X))
- SET START=X
- DO DOWN
- SET DA=ORGDA
- +12 KILL START,ORGDA
- +13 QUIT
- DOWN ; Insert this transaction & shift others one priority #
- +1 WRITE !!,"Reprioritizing this CMR's requests... Hold on..."
- +2 DO PRIMAX
- SET LPRI=LPRI+1
- SET ORGDA=DA
- NEW DA
- SET DA=ORGDA
- +3 SET ^PRCN(413,"P",PSER,START,ORGDA)=""
- +4 SET NXPR=START
- DO GETDA
- +5 IF OTHDA'=""
- IF OTHDA'=DA
- SET NXPR=START
- DO GETPR
- +6 KILL OTHDA,DA,NXPR,START,OLDA
- +7 QUIT
- XREF ; Special MUMPS cross-reference for priorities
- +1 SET PRCNX=$GET(X)
- +2 SET X=$PIECE($GET(^PRCN(413,DA,2)),U,18)
- +3 if '$DATA(PSER)
- DO PRIMAX
- +4 IF X=""
- IF $GET(PRCNX)'=""
- KILL ^PRCN(413,"P",PSER,PRCNX,DA),PRCNX
- QUIT
- XR SET STAT=$PIECE(^PRCN(413,DA,0),U,7)
- SET SK=0
- +1 IF STAT<5!(STAT>10)
- SET SK=1
- +2 IF STAT=31!(STAT=45)!(STAT=3)!(STAT=27)
- SET SK=0
- +3 IF SK=0
- SET ^PRCN(413,"P",PSER,X,DA)=""
- +4 IF SK=1
- KILL ^PRCN(413,"P",PSER,X,DA)
- +5 KILL PSER,SK,STAT
- +6 QUIT
- PRIMAX ; Calculate lowest priority. Used in input template, etc.
- +1 ; Returns OLDPRI, PSER, SERV, LPRI, and PRIMAX.
- +2 SET OLDPRI=$PIECE($GET(^PRCN(413,DA,2)),U,18)
- SET PSER=$PIECE($GET(^PRCN(413,DA,0)),U,3)
- +3 SET (II,PRIMAX)=0
- if PSER'=""
- SET SERV=$PIECE(^DIC(49,PSER,0),U)
- +4 IF PSER'=""
- FOR
- SET II=$ORDER(^PRCN(413,"P",PSER,II))
- if II=""
- QUIT
- SET PRIMAX=PRIMAX+1
- SET LPRI=II
- +5 IF +OLDPRI'=0
- SET PRIMAX=+OLDPRI
- QUIT
- +6 IF +OLDPRI=0
- IF $GET(LPRI)=""
- SET (PRIMAX,LPRI)=0
- QUIT
- +7 IF +OLDPRI=0
- IF $GET(LPRI)'=""
- SET PRIMAX=LPRI
- +8 KILL II
- +9 QUIT
- DPRI ; Display priorities. Called as special help for priority fld.
- +1 IF $GET(SERV)=""!($GET(PSER)="")
- DO PRIMAX
- +2 WRITE !!,"Priority list for ",SERV,":"
- +3 SET PRCNI=0
- FOR
- SET PRCNI=$ORDER(^PRCN(413,"P",PSER,PRCNI))
- if '+PRCNI
- QUIT
- Begin DoDot:1
- +4 SET J=$ORDER(^PRCN(413,"P",PSER,PRCNI,""))
- +5 IF $GET(^PRCN(413,J,0))=""
- KILL ^PRCN(413,"P",PSER,PRCNI,J)
- QUIT
- +6 WRITE !,PRCNI,?8,$PIECE(^PRCN(413,J,0),U),?25,$PIECE(^(0),U,18)
- End DoDot:1
- +7 KILL PRCNI,J
- +8 QUIT
- GETPR SET NXPR=$ORDER(^PRCN(413,"P",PSER,NXPR))
- +1 IF NXPR'=(START+1)
- SET NXPR=START+1
- DO SETDA
- QUIT
- +2 IF NXPR=(START+1)
- DO SETDA
- SET START=NXPR
- SET DA=OTHDA
- DO GETDA
- GOTO GETPR
- +3 QUIT
- SETDA SET $PIECE(^PRCN(413,OTHDA,2),U,18)=NXPR
- SET ^PRCN(413,"P",PSER,NXPR,OTHDA)=""
- +1 KILL ^PRCN(413,"P",PSER,START,OTHDA)
- +2 QUIT
- GETDA SET OLDA=""
- FOR
- SET OLDA=$ORDER(^PRCN(413,"P",PSER,NXPR,OLDA))
- if OLDA=""
- QUIT
- if OLDA'=DA
- SET OTHDA=OLDA
- +1 QUIT
