PRCNRNK ;SSI/ALA-Rank Requests for Committee ;[ 07/19/96 10:43 AM ]
;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
SELECT ; Select a transaction
W @IOF S DIC("S")="I $P(^(0),U,7)=10!($P(^(0),U,7)=31)",DIC="^PRCN(413,"
S DIC(0)="AEQZ" D ^DIC K DIC("S") G EXIT:Y<0
S IN=+Y,PRCNUSR=8 D SETUP^PRCNPRNT Q:$D(EDIT)
K DUOUT S DR="[PRCNRNK]",DIE="^PRCN(413,",DA=IN D ^DIE
G SELECT
EXIT K DIC,DIE,DA,IN,PRCNUSR,PRCC,OLDRANK,LPRI,PRCNDEF,EDIT,OLD,RANKMAX
K DR,C,D,D0
Q
RANKMAX ; Calculate maximum equipment committee rank
S OLDRANK=$P($G(^PRCN(413,IN,6)),U,3),(RANKMAX,I)=0
F S I=$O(^PRCN(413,"E",I)) Q:'I S RANKMAX=I
S RANKMAX=RANKMAX+1
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
Q:'$D(^PRCN(413,"E",X))
Q:$D(^PRCN(413,"E",X,DA))
NEW I
I $D(^PRCN(413,"E",X)) S START=X D DOWN S DA=ORGDA
K START,ORGDA
Q
DOWN ; Insert this transaction & shift others one priority #
S LPRI=RANKMAX S ORGDA=DA NEW DA S DA=ORGDA
S ^PRCN(413,"E",START,ORGDA)=""
S NXPR=START D GETDA
I OTHDA'="",OTHDA'=DA S NXPR=START D GETPR
K OTHDA,DA,NXPR,START,OLDA
Q
DRANK ; Display ranks. Called as special help for rank fld.
W !!,"Ranking list:" S I=0,PRCNCT=0
F S I=$O(^PRCN(413,"E",I)) Q:'+I D Q:$G(PRCC)'=""
. S J=$O(^PRCN(413,"E",I,"")),PRCNCT=PRCNCT+1
. I PRCNCT>20 D CHKPG Q:$G(PRCC)'=""
. W !,I,?8,$P(^PRCN(413,J,0),U),?28,$P(^PRCN(413,J,0),U,18)
K I,J,PRCC,PRCNCT
Q
CHKPG ; If printing to screen & it is full, clear screen
W !,"Hit RETURN to continue or '^' to quit. "
R PRCC:DTIME S:'$T PRCC=U I PRCC'?1"^".E K PRCC Q
S PRCNCT=0
Q
GETPR S NXPR=$O(^PRCN(413,"E",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,6),U,3)=NXPR,^PRCN(413,"E",NXPR,OTHDA)=""
K ^PRCN(413,"E",START,OTHDA)
Q
GETDA S OLDA="" F S OLDA=$O(^PRCN(413,"E",NXPR,OLDA)) Q:OLDA="" S:OLDA'=DA OTHDA=OLDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNRNK 2033 printed Apr 09, 2024@20:59:43 Page 2
PRCNRNK ;SSI/ALA-Rank Requests for Committee ;[ 07/19/96 10:43 AM ]
+1 ;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
SELECT ; Select a transaction
+1 WRITE @IOF
SET DIC("S")="I $P(^(0),U,7)=10!($P(^(0),U,7)=31)"
SET DIC="^PRCN(413,"
+2 SET DIC(0)="AEQZ"
DO ^DIC
KILL DIC("S")
if Y<0
GOTO EXIT
+3 SET IN=+Y
SET PRCNUSR=8
DO SETUP^PRCNPRNT
if $DATA(EDIT)
QUIT
+4 KILL DUOUT
SET DR="[PRCNRNK]"
SET DIE="^PRCN(413,"
SET DA=IN
DO ^DIE
+5 GOTO SELECT
EXIT KILL DIC,DIE,DA,IN,PRCNUSR,PRCC,OLDRANK,LPRI,PRCNDEF,EDIT,OLD,RANKMAX
+1 KILL DR,C,D,D0
+2 QUIT
RANKMAX ; Calculate maximum equipment committee rank
+1 SET OLDRANK=$PIECE($GET(^PRCN(413,IN,6)),U,3)
SET (RANKMAX,I)=0
+2 FOR
SET I=$ORDER(^PRCN(413,"E",I))
if 'I
QUIT
SET RANKMAX=I
+3 SET RANKMAX=RANKMAX+1
+4 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(^PRCN(413,"E",X))
QUIT
+5 if $DATA(^PRCN(413,"E",X,DA))
QUIT
+6 NEW I
+7 IF $DATA(^PRCN(413,"E",X))
SET START=X
DO DOWN
SET DA=ORGDA
+8 KILL START,ORGDA
+9 QUIT
DOWN ; Insert this transaction & shift others one priority #
+1 SET LPRI=RANKMAX
SET ORGDA=DA
NEW DA
SET DA=ORGDA
+2 SET ^PRCN(413,"E",START,ORGDA)=""
+3 SET NXPR=START
DO GETDA
+4 IF OTHDA'=""
IF OTHDA'=DA
SET NXPR=START
DO GETPR
+5 KILL OTHDA,DA,NXPR,START,OLDA
+6 QUIT
DRANK ; Display ranks. Called as special help for rank fld.
+1 WRITE !!,"Ranking list:"
SET I=0
SET PRCNCT=0
+2 FOR
SET I=$ORDER(^PRCN(413,"E",I))
if '+I
QUIT
Begin DoDot:1
+3 SET J=$ORDER(^PRCN(413,"E",I,""))
SET PRCNCT=PRCNCT+1
+4 IF PRCNCT>20
DO CHKPG
if $GET(PRCC)'=""
QUIT
+5 WRITE !,I,?8,$PIECE(^PRCN(413,J,0),U),?28,$PIECE(^PRCN(413,J,0),U,18)
End DoDot:1
if $GET(PRCC)'=""
QUIT
+6 KILL I,J,PRCC,PRCNCT
+7 QUIT
CHKPG ; If printing to screen & it is full, clear screen
+1 WRITE !,"Hit RETURN to continue or '^' to quit. "
+2 READ PRCC:DTIME
if '$TEST
SET PRCC=U
IF PRCC'?1"^".E
KILL PRCC
QUIT
+3 SET PRCNCT=0
+4 QUIT
GETPR SET NXPR=$ORDER(^PRCN(413,"E",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,6),U,3)=NXPR
SET ^PRCN(413,"E",NXPR,OTHDA)=""
+1 KILL ^PRCN(413,"E",START,OTHDA)
+2 QUIT
GETDA SET OLDA=""
FOR
SET OLDA=$ORDER(^PRCN(413,"E",NXPR,OLDA))
if OLDA=""
QUIT
if OLDA'=DA
SET OTHDA=OLDA
+1 QUIT
