ACRFTXTP ;IHS/OIRM/DSD/THL,AEF - LIST OF TRANSACTION TYPES; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;ROUTIN TO LIST OF TRANSACTION TYPES
EN K ACRQUIT,ACRTXTP
F D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
EXIT K ACRX,ACRTXNAM,ACRTX,ACRQUIT,ACRDOCDA,ACRTXDOC,ACRTT,ACRDUZ,ACRJ,ACRK,ACRI,ACRQK,ACRCNT,ACRLI,ACRUSER,ACR,ACRQK1,ACRZ
Q
EN1 D DISPLAY
D SELECT
Q
DISPLAY ;EP;TO DISPLAY TRANSACTION TYPES
W @IOF
I $D(ACRXDRCL) D
.W !?80-$L(ACRXDRCL)\2,ACRXDRCL
.W !?80-$L(ACRXDRCL)\2
.F ACRI=1:1:$L(ACRXDRCL) W "="
K ACRXDRCL,ACRI
W !!?2,"NO."
W ?7,"TRANSACTION TYPE"
W ?42,"NO."
W ?47,"TRANSACTION TYPE"
W !?2,"---"
W ?7,"------------------------------"
W ?42,"---"
W ?47,"------------------------------"
S (ACRJ,ACRTXDO)=0
F S ACRTXDO=$O(^ACRTXTYP("DO",ACRTXDO)) Q:'ACRTXDO D
.S ACRTXDA=0
.F S ACRTXDA=$O(^ACRTXTYP("DO",ACRTXDO,ACRTXDA)) Q:'ACRTXDA D
..I $D(ACRNEWOB),$D(ACRFDNO),$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) D Q
...S ACRTXNAM=$P(^ACRTXTYP(ACRTXDA,0),U)
...D DISP1
..I $D(ACRNEWOB),$D(ACRFDNO),'$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) Q
..S ACRTXNAM=$P(^ACRTXTYP(ACRTXDA,0),U)
..I $D(ACRLBTX),$E(ACRTXNAM,1,3)="REQ" D DISP1 Q
..D DISP1
D DISP2
Q
DISP1 I ACRTXDA=19&'$D(ACRTT) Q
S ACRJ=ACRJ+1
S ACRTX=ACRTXDA_"^"_^ACRTXTYP(ACRTXDA,0)
S ACRTX("DT")=^ACRTXTYP(ACRTXDA,"DT")
I $D(ACRFDNO),'$D(ACRCSI),'$D(ACRTT),$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) D
.S ACRTXDAX=$O(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA,0))
.I ACRTXDAX D I 1
..S ACRTXLIM=$P(^ACRLOCB(ACRFDNO,2,ACRTXDAX,0),U,2)
..S ACRTXLIM=$P(ACRTXLIM,".")
E S ACRTXLIM=0
S ACRTX(ACRJ)=ACRTX_"^LIM^"_ACRTXLIM
S ACRTX(ACRJ,"DT")=ACRTX("DT")
Q
DISP2 S ACRJJ=$S(ACRJ>1:ACRJ\2+(ACRJ#2),1:ACRJ)
F ACRI=1:1:ACRJJ D
.W:ACRI<ACRJJ!(ACRI=ACRJJ) !
.S ACRJJJ=ACRI
.D LBTX
.W ?2,ACRI
.W ?$X+3+$S($L(ACRI)=1:1,1:0),$P(ACRTX(ACRI),U,2)
.I $D(ACRTX(ACRI+ACRJJ)) D
..S ACRJJJ=ACRI+ACRJJ
..D LBTX
..W ?42,ACRJJJ
..W ?$X+3+$S($L(ACRJJJ)=1:1,1:0),$P(ACRTX(ACRJJJ),U,2)
Q
LBTX I $D(ACRLBTX),$D(ACRZDA),$D(^ACRLOCB(ACRZDA,2,+ACRTX(ACRJJJ))) D
.I ACRI=ACRJJJ W ""
.E W ?40
.W "**"
Q
SELECT ;EP;
S DIR(0)="NO^1:"_ACRJ
S DIR("A")="Which Transaction Type ==> "
W !
D DIR^ACRFDIC
I U[$E(X)!(X="")!(+Y<1) S (ACRQUIT,ACRTXTP)="" Q
S (ACRY,ACRX)=+Y
S ACRTXDA=$P(ACRTX(ACRX),U)
S ACRREFDA=$P(ACRTX(ACRX),U,3)
S ACRTXLIM=$S($P(ACRTX(ACRX),"^LIM^",2)]"":$P(ACRTX(ACRX),"^LIM^",2),1:"UNSPEC")
S ACRTXOBJ=$P(ACRTX(ACRX),U,4)
S ACRQUIT=""
S ACRTXPFX=$P(ACRTX(ACRX,"DT"),U,2)
D OC:ACRTXDA'=35&(ACRTXDA'=31)
Q
OC ;DISPLAY RELATED OBJECT CLASS CODES
S DIR(0)="YO"
S DIR("A")="Display Related Object Class Codes"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
I U[$E(X) S (ACRQUIT,ACROUT)="" Q
I +Y'=1 S ACRQUIT="" Q
W @IOF,!?5,"Object Class Codes for ",$P(^ACRTXTYP(ACRTXDA,0),U)
W !?5,"---- ----------------------------------------------------------"
W !?5
I ACRTXDA=31 D
.W !,"Applicable Object Class Codes for a REQ FOR CALL AGAINST A BPA"
.W !,"will depend on the original BPA."
N ACRX
S ACRX=0
F S ACRX=$O(^ACRTXTYP(ACRTXDA,10,ACRX)) Q:'ACRX!$D(ACRQUIT)!$D(ACROUT) D:$D(^AUTTOBJC(ACRX,0))
.S ACROC=^AUTTOBJC(ACRX,0)
.W !?5,$P(ACROC,U),?11,$P(ACROC,U,3)
.I $Y>(IOSL-4) D PAUSE^ACRFWARN W @IOF
D PAUSE^ACRFWARN
K ACRQUIT,ACROUT
Q
ACRFTXTP ;IHS/OIRM/DSD/THL,AEF - LIST OF TRANSACTION TYPES; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;ROUTIN TO LIST OF TRANSACTION TYPES
EN KILL ACRQUIT,ACRTXTP
+1 FOR
DO EN1
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
EXIT KILL ACRX,ACRTXNAM,ACRTX,ACRQUIT,ACRDOCDA,ACRTXDOC,ACRTT,ACRDUZ,ACRJ,ACRK,ACRI,ACRQK,ACRCNT,ACRLI,ACRUSER,ACR,ACRQK1,ACRZ
+1 QUIT
EN1 DO DISPLAY
+1 DO SELECT
+2 QUIT
DISPLAY ;EP;TO DISPLAY TRANSACTION TYPES
+1 WRITE @IOF
+2 IF $DATA(ACRXDRCL)
Begin DoDot:1
+3 WRITE !?80-$LENGTH(ACRXDRCL)\2,ACRXDRCL
+4 WRITE !?80-$LENGTH(ACRXDRCL)\2
+5 FOR ACRI=1:1:$LENGTH(ACRXDRCL)
WRITE "="
End DoDot:1
+6 KILL ACRXDRCL,ACRI
+7 WRITE !!?2,"NO."
+8 WRITE ?7,"TRANSACTION TYPE"
+9 WRITE ?42,"NO."
+10 WRITE ?47,"TRANSACTION TYPE"
+11 WRITE !?2,"---"
+12 WRITE ?7,"------------------------------"
+13 WRITE ?42,"---"
+14 WRITE ?47,"------------------------------"
+15 SET (ACRJ,ACRTXDO)=0
+16 FOR
SET ACRTXDO=$ORDER(^ACRTXTYP("DO",ACRTXDO))
IF 'ACRTXDO
QUIT
Begin DoDot:1
+17 SET ACRTXDA=0
+18 FOR
SET ACRTXDA=$ORDER(^ACRTXTYP("DO",ACRTXDO,ACRTXDA))
IF 'ACRTXDA
QUIT
Begin DoDot:2
+19 IF $DATA(ACRNEWOB)
IF $DATA(ACRFDNO)
IF $DATA(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA))
Begin DoDot:3
+20 SET ACRTXNAM=$PIECE(^ACRTXTYP(ACRTXDA,0),U)
+21 DO DISP1
End DoDot:3
QUIT
+22 IF $DATA(ACRNEWOB)
IF $DATA(ACRFDNO)
IF '$DATA(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA))
QUIT
+23 SET ACRTXNAM=$PIECE(^ACRTXTYP(ACRTXDA,0),U)
+24 IF $DATA(ACRLBTX)
IF $EXTRACT(ACRTXNAM,1,3)="REQ"
DO DISP1
QUIT
+25 DO DISP1
End DoDot:2
End DoDot:1
+26 DO DISP2
+27 QUIT
DISP1 IF ACRTXDA=19&'$DATA(ACRTT)
QUIT
+1 SET ACRJ=ACRJ+1
+2 SET ACRTX=ACRTXDA_"^"_^ACRTXTYP(ACRTXDA,0)
+3 SET ACRTX("DT")=^ACRTXTYP(ACRTXDA,"DT")
+4 IF $DATA(ACRFDNO)
IF '$DATA(ACRCSI)
IF '$DATA(ACRTT)
IF $DATA(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA))
Begin DoDot:1
+5 SET ACRTXDAX=$ORDER(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA,0))
+6 IF ACRTXDAX
Begin DoDot:2
+7 SET ACRTXLIM=$PIECE(^ACRLOCB(ACRFDNO,2,ACRTXDAX,0),U,2)
+8 SET ACRTXLIM=$PIECE(ACRTXLIM,".")
End DoDot:2
IF 1
End DoDot:1
+9 IF '$TEST
SET ACRTXLIM=0
+10 SET ACRTX(ACRJ)=ACRTX_"^LIM^"_ACRTXLIM
+11 SET ACRTX(ACRJ,"DT")=ACRTX("DT")
+12 QUIT
DISP2 SET ACRJJ=$SELECT(ACRJ>1:ACRJ\2+(ACRJ#2),1:ACRJ)
+1 FOR ACRI=1:1:ACRJJ
Begin DoDot:1
+2 IF ACRI<ACRJJ!(ACRI=ACRJJ)
WRITE !
+3 SET ACRJJJ=ACRI
+4 DO LBTX
+5 WRITE ?2,ACRI
+6 WRITE ?$X+3+$SELECT($LENGTH(ACRI)=1:1,1:0),$PIECE(ACRTX(ACRI),U,2)
+7 IF $DATA(ACRTX(ACRI+ACRJJ))
Begin DoDot:2
+8 SET ACRJJJ=ACRI+ACRJJ
+9 DO LBTX
+10 WRITE ?42,ACRJJJ
+11 WRITE ?$X+3+$SELECT($LENGTH(ACRJJJ)=1:1,1:0),$PIECE(ACRTX(ACRJJJ),U,2)
End DoDot:2
End DoDot:1
+12 QUIT
LBTX IF $DATA(ACRLBTX)
IF $DATA(ACRZDA)
IF $DATA(^ACRLOCB(ACRZDA,2,+ACRTX(ACRJJJ)))
Begin DoDot:1
+1 IF ACRI=ACRJJJ
WRITE ""
+2 IF '$TEST
WRITE ?40
+3 WRITE "**"
End DoDot:1
+4 QUIT
SELECT ;EP;
+1 SET DIR(0)="NO^1:"_ACRJ
+2 SET DIR("A")="Which Transaction Type ==> "
+3 WRITE !
+4 DO DIR^ACRFDIC
+5 IF U[$EXTRACT(X)!(X="")!(+Y<1)
SET (ACRQUIT,ACRTXTP)=""
QUIT
+6 SET (ACRY,ACRX)=+Y
+7 SET ACRTXDA=$PIECE(ACRTX(ACRX),U)
+8 SET ACRREFDA=$PIECE(ACRTX(ACRX),U,3)
+9 SET ACRTXLIM=$SELECT($PIECE(ACRTX(ACRX),"^LIM^",2)]"":$PIECE(ACRTX(ACRX),"^LIM^",2),1:"UNSPEC")
+10 SET ACRTXOBJ=$PIECE(ACRTX(ACRX),U,4)
+11 SET ACRQUIT=""
+12 SET ACRTXPFX=$PIECE(ACRTX(ACRX,"DT"),U,2)
+13 IF ACRTXDA'=35&(ACRTXDA'=31)
DO OC
+14 QUIT
OC ;DISPLAY RELATED OBJECT CLASS CODES
+1 SET DIR(0)="YO"
+2 SET DIR("A")="Display Related Object Class Codes"
+3 SET DIR("B")="NO"
+4 WRITE !
+5 DO DIR^ACRFDIC
+6 IF U[$EXTRACT(X)
SET (ACRQUIT,ACROUT)=""
QUIT
+7 IF +Y'=1
SET ACRQUIT=""
QUIT
+8 WRITE @IOF,!?5,"Object Class Codes for ",$PIECE(^ACRTXTYP(ACRTXDA,0),U)
+9 WRITE !?5,"---- ----------------------------------------------------------"
+10 WRITE !?5
+11 IF ACRTXDA=31
Begin DoDot:1
+12 WRITE !,"Applicable Object Class Codes for a REQ FOR CALL AGAINST A BPA"
+13 WRITE !,"will depend on the original BPA."
End DoDot:1
+14 NEW ACRX
+15 SET ACRX=0
+16 FOR
SET ACRX=$ORDER(^ACRTXTYP(ACRTXDA,10,ACRX))
IF 'ACRX!$DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
IF $DATA(^AUTTOBJC(ACRX,0))
Begin DoDot:1
+17 SET ACROC=^AUTTOBJC(ACRX,0)
+18 WRITE !?5,$PIECE(ACROC,U),?11,$PIECE(ACROC,U,3)
+19 IF $Y>(IOSL-4)
DO PAUSE^ACRFWARN
WRITE @IOF
End DoDot:1
+20 DO PAUSE^ACRFWARN
+21 KILL ACRQUIT,ACROUT
+22 QUIT
