Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACRFTXTP

ACRFTXTP.m

Go to the documentation of this file. 
  1. 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
  1.  ;;ROUTIN TO LIST OF TRANSACTION TYPES
  1. EN K ACRQUIT,ACRTXTP
  1.  F  D EN1 Q:$D(ACRQUIT)!$D(ACROUT)
  1. EXIT K ACRX,ACRTXNAM,ACRTX,ACRQUIT,ACRDOCDA,ACRTXDOC,ACRTT,ACRDUZ,ACRJ,ACRK,ACRI,ACRQK,ACRCNT,ACRLI,ACRUSER,ACR,ACRQK1,ACRZ
  1.  Q
  1. EN1 D DISPLAY
  1.  D SELECT
  1.  Q
  1. DISPLAY ;EP;TO DISPLAY TRANSACTION TYPES
  1.  W @IOF
  1.  I $D(ACRXDRCL) D
  1.  .W !?80-$L(ACRXDRCL)\2,ACRXDRCL
  1.  .W !?80-$L(ACRXDRCL)\2
  1.  .F ACRI=1:1:$L(ACRXDRCL) W "="
  1.  K ACRXDRCL,ACRI
  1.  W !!?2,"NO."
  1.  W ?7,"TRANSACTION TYPE"
  1.  W ?42,"NO."
  1.  W ?47,"TRANSACTION TYPE"
  1.  W !?2,"---"
  1.  W ?7,"------------------------------"
  1.  W ?42,"---"
  1.  W ?47,"------------------------------"
  1.  S (ACRJ,ACRTXDO)=0
  1.  F  S ACRTXDO=$O(^ACRTXTYP("DO",ACRTXDO)) Q:'ACRTXDO  D
  1.  .S ACRTXDA=0
  1.  .F  S ACRTXDA=$O(^ACRTXTYP("DO",ACRTXDO,ACRTXDA)) Q:'ACRTXDA  D
  1.  ..I $D(ACRNEWOB),$D(ACRFDNO),$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) D  Q
  1.  ...S ACRTXNAM=$P(^ACRTXTYP(ACRTXDA,0),U)
  1.  ...D DISP1
  1.  ..I $D(ACRNEWOB),$D(ACRFDNO),'$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) Q
  1.  ..S ACRTXNAM=$P(^ACRTXTYP(ACRTXDA,0),U)
  1.  ..I $D(ACRLBTX),$E(ACRTXNAM,1,3)="REQ" D DISP1 Q
  1.  ..D DISP1
  1.  D DISP2
  1.  Q
  1. DISP1 I ACRTXDA=19&'$D(ACRTT) Q
  1.  S ACRJ=ACRJ+1
  1.  S ACRTX=ACRTXDA_"^"_^ACRTXTYP(ACRTXDA,0)
  1.  S ACRTX("DT")=^ACRTXTYP(ACRTXDA,"DT")
  1.  I $D(ACRFDNO),'$D(ACRCSI),'$D(ACRTT),$D(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA)) D
  1.  .S ACRTXDAX=$O(^ACRLOCB(ACRFDNO,2,"B",ACRTXDA,0))
  1.  .I ACRTXDAX D  I 1
  1.  ..S ACRTXLIM=$P(^ACRLOCB(ACRFDNO,2,ACRTXDAX,0),U,2)
  1.  ..S ACRTXLIM=$P(ACRTXLIM,".")
  1.  E  S ACRTXLIM=0
  1.  S ACRTX(ACRJ)=ACRTX_"^LIM^"_ACRTXLIM
  1.  S ACRTX(ACRJ,"DT")=ACRTX("DT")
  1.  Q
  1. DISP2 S ACRJJ=$S(ACRJ>1:ACRJ\2+(ACRJ#2),1:ACRJ)
  1.  F ACRI=1:1:ACRJJ D
  1.  .W:ACRI<ACRJJ!(ACRI=ACRJJ) !
  1.  .S ACRJJJ=ACRI
  1.  .D LBTX
  1.  .W ?2,ACRI
  1.  .W ?$X+3+$S($L(ACRI)=1:1,1:0),$P(ACRTX(ACRI),U,2)
  1.  .I $D(ACRTX(ACRI+ACRJJ)) D
  1.  ..S ACRJJJ=ACRI+ACRJJ
  1.  ..D LBTX
  1.  ..W ?42,ACRJJJ
  1.  ..W ?$X+3+$S($L(ACRJJJ)=1:1,1:0),$P(ACRTX(ACRJJJ),U,2)
  1.  Q
  1. LBTX I $D(ACRLBTX),$D(ACRZDA),$D(^ACRLOCB(ACRZDA,2,+ACRTX(ACRJJJ))) D
  1.  .I ACRI=ACRJJJ W ""
  1.  .E  W ?40
  1.  .W "**"
  1.  Q
  1. SELECT ;EP;
  1.  S DIR(0)="NO^1:"_ACRJ
  1.  S DIR("A")="Which Transaction Type ==> "
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I U[$E(X)!(X="")!(+Y<1) S (ACRQUIT,ACRTXTP)="" Q
  1.  S (ACRY,ACRX)=+Y
  1.  S ACRTXDA=$P(ACRTX(ACRX),U)
  1.  S ACRREFDA=$P(ACRTX(ACRX),U,3)
  1.  S ACRTXLIM=$S($P(ACRTX(ACRX),"^LIM^",2)]"":$P(ACRTX(ACRX),"^LIM^",2),1:"UNSPEC")
  1.  S ACRTXOBJ=$P(ACRTX(ACRX),U,4)
  1.  S ACRQUIT=""
  1.  S ACRTXPFX=$P(ACRTX(ACRX,"DT"),U,2)
  1.  D OC:ACRTXDA'=35&(ACRTXDA'=31)
  1.  Q
  1. OC ;DISPLAY RELATED OBJECT CLASS CODES
  1.  S DIR(0)="YO"
  1.  S DIR("A")="Display Related Object Class Codes"
  1.  S DIR("B")="NO"
  1.  W !
  1.  D DIR^ACRFDIC
  1.  I U[$E(X) S (ACRQUIT,ACROUT)="" Q
  1.  I +Y'=1 S ACRQUIT="" Q
  1.  W @IOF,!?5,"Object Class Codes for ",$P(^ACRTXTYP(ACRTXDA,0),U)
  1.  W !?5,"----  ----------------------------------------------------------"
  1.  W !?5
  1.  I ACRTXDA=31 D
  1.  .W !,"Applicable Object Class Codes for a REQ FOR CALL AGAINST A BPA"
  1.  .W !,"will depend on the original BPA."
  1.  N ACRX
  1.  S ACRX=0
  1.  F  S ACRX=$O(^ACRTXTYP(ACRTXDA,10,ACRX)) Q:'ACRX!$D(ACRQUIT)!$D(ACROUT)  D:$D(^AUTTOBJC(ACRX,0))
  1.  .S ACROC=^AUTTOBJC(ACRX,0)
  1.  .W !?5,$P(ACROC,U),?11,$P(ACROC,U,3)
  1.  .I $Y>(IOSL-4) D PAUSE^ACRFWARN W @IOF
  1.  D PAUSE^ACRFWARN
  1.  K ACRQUIT,ACROUT
  1.  Q