- %AUPTFXS ;BRJ/IHS OHPD STACK FILE/$O/DA VARIABLE TABLES [ 03/17/87 10:39 AM ]
- W !,*7,"%AUPTFXS cannot be run stand-alone. Check your documentation!"
- Q
- EN ;ENTRY FROM ^%AUPTFX DRIVER
- NEW AUPTPGM S AUPTPGM="<"_$T(+0)_">"
- D STACK,LOOPIT
- Q
- STACK ;STACK ALL FILES WITH "PT" NODES (POINTING OR POINTED TO)
- S AUPTI1=0,AUPTI2=1
- F L=0:0 S AUPTI1=$O(AUPTFSTK(AUPTI1)) Q:'+AUPTI1 S AUPTDDFL=AUPTFSTK(AUPTI1),AUPTPTFL="" F L=0:0 S AUPTPTFL=$O(^DD(AUPTDDFL,0,"PT",AUPTPTFL)) Q:'+AUPTPTFL D STACKIT
- Q
- STACKIT ;GET FIELD NUMBER FOR STACK
- S AUPTPTFD=""
- F L=0:0 S AUPTPTFD=$O(^DD(AUPTDDFL,0,"PT",AUPTPTFL,AUPTPTFD)) Q:'+AUPTPTFD S ^AUPTSTCK(AUPTPTFL,AUPTPTFD)="" I AUPTPTFD=.01 S AUPTI2=AUPTI2+1 S AUPTFSTK(AUPTI2)=AUPTPTFL
- Q
- LOOPIT ;LOOP THRU SUB-ROUTINES AND SWAP DATA VALUES
- ;LOOP THROUGH "PT" NODES OF SELECTED FILEMAN FILE
- S AUPTHIT=0,AUPTPFL=""
- F L=0:0 S AUPTSKIP=0,(AUPTPFL,AUPTPSFL)=$O(^AUPTSTCK(AUPTPFL)) Q:'+AUPTPFL S AUPTPFD="" F L=0:0 S (AUPTPFD,AUPTPSFD)=$O(^AUPTSTCK(AUPTPFL,AUPTPFD)) Q:'+AUPTPFD F AUPTLBL="DDCK","BLDDA","SETGLREF","SWAP" D @(AUPTLBL):'AUPTSKIP
- I 'AUPTHIT S AUPTEC=1 D ERR^AUPTFXT
- Q
- DDCK ;CHECK ^DD FOR EXISTANCE OF FILE/FIELD '0' NODE
- I $D(^DD(AUPTPFL,AUPTPFD,0)) S AUPTHIT=1 Q
- S AUPTEC=2 D ERR^AUPTFXT
- Q
- BLDDA ;LOOP UP ^DD TO BUILD 'DA' TABLE FROM FILE/SUBFILE INFO
- S (AUPTI,AUPTDIN)=0
- I AUPTPSFD=.01&($P(^DD(AUPTPSFL,AUPTPSFD,0),U,5)["DINUM") S AUPTDIN=1,AUPTDXGL=$P(^(0),U,3) I AUPTDXGL="" S AUPTEC=7 D ERR^AUPTFXT S AUPTSKIP=1 Q
- K AUPTDAL,DA
- D TBLDA
- Q:AUPTSKIP
- UPDD ;GO UP ^DD FOR ALL SUBFILES AND ADD TO 'DA' TABLE
- F L=0:0 Q:'$D(^DD(AUPTPSFL,0,"UP")) S AUPTPSFL=^("UP"),AUPTPSNM="",AUPTPSNM=$O(^("NM",AUPTPSNM)) D UPDDNMCK Q:AUPTSKIP S AUPTPSFD="",AUPTPSFD=$O(^DD(AUPTPSFL,"B",AUPTPSNM,AUPTPSFD)) D UPDDFDCK Q:AUPTSKIP D TBLDA Q:AUPTSKIP
- S AUPTDACT=AUPTI*(-1)
- S AUPTP=$P($P(AUPTDAL(-1),";",2),U,1)
- Q
- UPDDNMCK ;CHECK IF "NM" VALUE OR ^DD(file,0,"NM" node exists
- I AUPTPSNM="" S AUPTEC=3 D ERR^AUPTFXT
- Q
- UPDDFDCK ;CHECK IF "B" VALUE OR ^DD(file,"B",name,field node exists
- I AUPTPSFD="" S AUPTEC=4 D ERR^AUPTFXT Q
- I '$D(^DD(AUPTPSFL,AUPTPSFD,0)) S AUPTEC=2 D ERR^AUPTFXT Q
- Q
- TBLDACMT ;CHECK IF THIS IS A FIELD NODE FOR THIS FILE/FIELD
- ;BUILD TABLE WITH 'DA' SUBSCRIPT AND SUBFILE;PIECE VALUES..EXAMPLE:
- ; AUPTDAL(-2)="DA(1),11;0" SUBFILE WILL HAVE '0' FOR FIELD VALUE
- ; AUPTDAL(-1)="DA,11;3" (-1) ALWAYS BOTTOM OF TABLE
- ; THERE WILL BE AS MANY ENTRIES AS THERE ARE SUBFILES
- ; **NOTE** NEGATIVE SUBSCRIPTS - TABLE IS BUILT FROM BOTTOM TO TOP -
- ; THEREBY FACILITATING A TOP-DOWN $O LATER ON TO BUILD THE FILE'S
- ; GLOBAL NODE
- TBLDA ;
- I '$D(^DD(AUPTPSFL,0,"UP")) I '$D(^DIC(AUPTPSFL,0)) S AUPTEC=8 D ERR^AUPTFXT Q
- S AUPTI=AUPTI-1,AUPTDAL(AUPTI)=$S(AUPTI<(-1):"DA("_((AUPTI*-1)-1)_")",1:"DA"),AUPTDAL(AUPTI)=AUPTDAL(AUPTI)_U_$P(^DD(AUPTPSFL,AUPTPSFD,0),U,4)
- TBLDAFL ;ADD THE FILE NAME AND NUMBER TO THE 'DA' TABLE ENTRY
- S AUPTDAL(AUPTI)=AUPTDAL(AUPTI)_U_AUPTPSFL_U_$S('$D(^DD(AUPTPSFL,0,"UP")):$P(^DIC(AUPTPSFL,0),U,1),1:$P(^DD(AUPTPSFL,0),U,1))
- S:AUPTI=(-1) AUPTDAL(-1)=AUPTDAL(-1)_U_AUPTPSFD_U_$P(^DD(AUPTPSFL,AUPTPSFD,0),U,1)
- Q
- SETGLREF ;GET GLOBAL REFERENCE FROM ^DIC FOR THIS FILE OR SUBFILE
- I '$D(^DIC(AUPTPSFL,0,"GL")) S AUPTEC=6 D ERR^AUPTFXT Q
- S (AUPTORGG,AUPTPGL)=^("GL")
- S AUPTCOMA=1 S:AUPTORGG["," AUPTCOMA=0
- ;SET GLOBAL NODE SUBSCRIPTS FOR FILE TO BE PROCESSED
- K AUPTO S AUPTI=""
- F AUPTL=1:1:AUPTDACT S AUPTI=$O(AUPTDAL(AUPTI)),AUPTPGL=AUPTPGL_$P(AUPTDAL(AUPTI),U,1)_","_$P($P(AUPTDAL(AUPTI),";",1),U,2),AUPTPGL=$S(AUPTI<(-1):AUPTPGL_",",1:AUPTPGL_")") D BLDSERCH
- Q
- BLDSERCH ;BUILD SEARCH $O ARRAY USED TO POSITION DATA GLOBAL FOR FILE/SUBFILE
- S AUPTDA=$P(AUPTDAL(AUPTI),U,1)
- S AUPTO(AUPTL,0)="S "_AUPTDA_$S(AUPTL=AUPTDACT:"=0",1:"=""""")
- S AUPTO(AUPTL,1)=$S(AUPTL=1:"S "_AUPTDA_"=$O("_AUPTORGG_AUPTDA_"))",1:"S "_AUPTDA_"="_$P($P(AUPTO((AUPTL-1),1),"))",1),"=",2)_"),"_$P($P(AUPTDAL(AUPTI-1),";",1),U,2)_","_AUPTDA_"))")
- S AUPTO(AUPTL,1)=$S(AUPTI'=(-1):AUPTO(AUPTL,1)_" S AUPTI=$S(+"_AUPTDA_":AUPTI+1,1:AUPTI-1)",1:AUPTO(AUPTL,1)_" S:'+DA AUPTI=AUPTI-1")
- Q
- SWAP ;CALL ^%AUPTFXX to exchange data values
- D EN^AUPTFXX,GET^AUPTFXD:AUPTDIN&$D(^AUPTFXD(AUPTPSFL,AUPTPSFD))
- Q
- %AUPTFXS ;BRJ/IHS OHPD STACK FILE/$O/DA VARIABLE TABLES [ 03/17/87 10:39 AM ]
- +1 WRITE !,*7,"%AUPTFXS cannot be run stand-alone. Check your documentation!"
- +2 QUIT
- EN ;ENTRY FROM ^%AUPTFX DRIVER
- +1 NEW AUPTPGM
- SET AUPTPGM="<"_$TEXT(+0)_">"
- +2 DO STACK
- DO LOOPIT
- +3 QUIT
- STACK ;STACK ALL FILES WITH "PT" NODES (POINTING OR POINTED TO)
- +1 SET AUPTI1=0
- SET AUPTI2=1
- +2 FOR L=0:0
- SET AUPTI1=$ORDER(AUPTFSTK(AUPTI1))
- IF '+AUPTI1
- QUIT
- SET AUPTDDFL=AUPTFSTK(AUPTI1)
- SET AUPTPTFL=""
- FOR L=0:0
- SET AUPTPTFL=$ORDER(^DD(AUPTDDFL,0,"PT",AUPTPTFL))
- IF '+AUPTPTFL
- QUIT
- DO STACKIT
- +3 QUIT
- STACKIT ;GET FIELD NUMBER FOR STACK
- +1 SET AUPTPTFD=""
- +2 FOR L=0:0
- SET AUPTPTFD=$ORDER(^DD(AUPTDDFL,0,"PT",AUPTPTFL,AUPTPTFD))
- IF '+AUPTPTFD
- QUIT
- SET ^AUPTSTCK(AUPTPTFL,AUPTPTFD)=""
- IF AUPTPTFD=.01
- SET AUPTI2=AUPTI2+1
- SET AUPTFSTK(AUPTI2)=AUPTPTFL
- +3 QUIT
- LOOPIT ;LOOP THRU SUB-ROUTINES AND SWAP DATA VALUES
- +1 ;LOOP THROUGH "PT" NODES OF SELECTED FILEMAN FILE
- +2 SET AUPTHIT=0
- SET AUPTPFL=""
- +3 FOR L=0:0
- SET AUPTSKIP=0
- SET (AUPTPFL,AUPTPSFL)=$ORDER(^AUPTSTCK(AUPTPFL))
- IF '+AUPTPFL
- QUIT
- SET AUPTPFD=""
- FOR L=0:0
- SET (AUPTPFD,AUPTPSFD)=$ORDER(^AUPTSTCK(AUPTPFL,AUPTPFD))
- IF '+AUPTPFD
- QUIT
- FOR AUPTLBL="DDCK","BLDDA","SETGLREF","SWAP"
- IF 'AUPTSKIP
- DO @(AUPTLBL)
- +4 IF 'AUPTHIT
- SET AUPTEC=1
- DO ERR^AUPTFXT
- +5 QUIT
- DDCK ;CHECK ^DD FOR EXISTANCE OF FILE/FIELD '0' NODE
- +1 IF $DATA(^DD(AUPTPFL,AUPTPFD,0))
- SET AUPTHIT=1
- QUIT
- +2 SET AUPTEC=2
- DO ERR^AUPTFXT
- +3 QUIT
- BLDDA ;LOOP UP ^DD TO BUILD 'DA' TABLE FROM FILE/SUBFILE INFO
- +1 SET (AUPTI,AUPTDIN)=0
- +2 IF AUPTPSFD=.01&($PIECE(^DD(AUPTPSFL,AUPTPSFD,0),U,5)["DINUM")
- SET AUPTDIN=1
- SET AUPTDXGL=$PIECE(^(0),U,3)
- IF AUPTDXGL=""
- SET AUPTEC=7
- DO ERR^AUPTFXT
- SET AUPTSKIP=1
- QUIT
- +3 KILL AUPTDAL,DA
- +4 DO TBLDA
- +5 IF AUPTSKIP
- QUIT
- UPDD ;GO UP ^DD FOR ALL SUBFILES AND ADD TO 'DA' TABLE
- +1 FOR L=0:0
- IF '$DATA(^DD(AUPTPSFL,0,"UP"))
- QUIT
- SET AUPTPSFL=^("UP")
- SET AUPTPSNM=""
- SET AUPTPSNM=$ORDER(^("NM",AUPTPSNM))
- DO UPDDNMCK
- IF AUPTSKIP
- QUIT
- SET AUPTPSFD=""
- SET AUPTPSFD=$ORDER(^DD(AUPTPSFL,"B",AUPTPSNM,AUPTPSFD))
- DO UPDDFDCK
- IF AUPTSKIP
- QUIT
- DO TBLDA
- IF AUPTSKIP
- QUIT
- +2 SET AUPTDACT=AUPTI*(-1)
- +3 SET AUPTP=$PIECE($PIECE(AUPTDAL(-1),";",2),U,1)
- +4 QUIT
- UPDDNMCK ;CHECK IF "NM" VALUE OR ^DD(file,0,"NM" node exists
- +1 IF AUPTPSNM=""
- SET AUPTEC=3
- DO ERR^AUPTFXT
- +2 QUIT
- UPDDFDCK ;CHECK IF "B" VALUE OR ^DD(file,"B",name,field node exists
- +1 IF AUPTPSFD=""
- SET AUPTEC=4
- DO ERR^AUPTFXT
- QUIT
- +2 IF '$DATA(^DD(AUPTPSFL,AUPTPSFD,0))
- SET AUPTEC=2
- DO ERR^AUPTFXT
- QUIT
- +3 QUIT
- TBLDACMT ;CHECK IF THIS IS A FIELD NODE FOR THIS FILE/FIELD
- +1 ;BUILD TABLE WITH 'DA' SUBSCRIPT AND SUBFILE;PIECE VALUES..EXAMPLE:
- +2 ; AUPTDAL(-2)="DA(1),11;0" SUBFILE WILL HAVE '0' FOR FIELD VALUE
- +3 ; AUPTDAL(-1)="DA,11;3" (-1) ALWAYS BOTTOM OF TABLE
- +4 ; THERE WILL BE AS MANY ENTRIES AS THERE ARE SUBFILES
- +5 ; **NOTE** NEGATIVE SUBSCRIPTS - TABLE IS BUILT FROM BOTTOM TO TOP -
- +6 ; THEREBY FACILITATING A TOP-DOWN $O LATER ON TO BUILD THE FILE'S
- +7 ; GLOBAL NODE
- TBLDA ;
- +1 IF '$DATA(^DD(AUPTPSFL,0,"UP"))
- IF '$DATA(^DIC(AUPTPSFL,0))
- SET AUPTEC=8
- DO ERR^AUPTFXT
- QUIT
- +2 SET AUPTI=AUPTI-1
- SET AUPTDAL(AUPTI)=$SELECT(AUPTI<(-1):"DA("_((AUPTI*-1)-1)_")",1:"DA")
- SET AUPTDAL(AUPTI)=AUPTDAL(AUPTI)_U_$PIECE(^DD(AUPTPSFL,AUPTPSFD,0),U,4)
- TBLDAFL ;ADD THE FILE NAME AND NUMBER TO THE 'DA' TABLE ENTRY
- +1 SET AUPTDAL(AUPTI)=AUPTDAL(AUPTI)_U_AUPTPSFL_U_$SELECT('$DATA(^DD(AUPTPSFL,0,"UP")):$PIECE(^DIC(AUPTPSFL,0),U,1),1:$PIECE(^DD(AUPTPSFL,0),U,1))
- +2 IF AUPTI=(-1)
- SET AUPTDAL(-1)=AUPTDAL(-1)_U_AUPTPSFD_U_$PIECE(^DD(AUPTPSFL,AUPTPSFD,0),U,1)
- +3 QUIT
- SETGLREF ;GET GLOBAL REFERENCE FROM ^DIC FOR THIS FILE OR SUBFILE
- +1 IF '$DATA(^DIC(AUPTPSFL,0,"GL"))
- SET AUPTEC=6
- DO ERR^AUPTFXT
- QUIT
- +2 SET (AUPTORGG,AUPTPGL)=^("GL")
- +3 SET AUPTCOMA=1
- IF AUPTORGG[","
- SET AUPTCOMA=0
- +4 ;SET GLOBAL NODE SUBSCRIPTS FOR FILE TO BE PROCESSED
- +5 KILL AUPTO
- SET AUPTI=""
- +6 FOR AUPTL=1:1:AUPTDACT
- SET AUPTI=$ORDER(AUPTDAL(AUPTI))
- SET AUPTPGL=AUPTPGL_$PIECE(AUPTDAL(AUPTI),U,1)_","_$PIECE($PIECE(AUPTDAL(AUPTI),";",1),U,2)
- SET AUPTPGL=$SELECT(AUPTI<(-1):AUPTPGL_",",1:AUPTPGL_")")
- DO BLDSERCH
- +7 QUIT
- BLDSERCH ;BUILD SEARCH $O ARRAY USED TO POSITION DATA GLOBAL FOR FILE/SUBFILE
- +1 SET AUPTDA=$PIECE(AUPTDAL(AUPTI),U,1)
- +2 SET AUPTO(AUPTL,0)="S "_AUPTDA_$SELECT(AUPTL=AUPTDACT:"=0",1:"=""""")
- +3 SET AUPTO(AUPTL,1)=$SELECT(AUPTL=1:"S "_AUPTDA_"=$O("_AUPTORGG_AUPTDA_"))",1:"S "_AUPTDA_"="_$PIECE($PIECE(AUPTO((AUPTL-1),1),"))",1),"=",2)_"),"_$PIECE($PIECE(AUPTDAL(AUPTI-1),";",1),U,2)_","_AUPTDA_"))")
- +4 SET AUPTO(AUPTL,1)=$SELECT(AUPTI'=(-1):AUPTO(AUPTL,1)_" S AUPTI=$S(+"_AUPTDA_":AUPTI+1,1:AUPTI-1)",1:AUPTO(AUPTL,1)_" S:'+DA AUPTI=AUPTI-1")
- +5 QUIT
- SWAP ;CALL ^%AUPTFXX to exchange data values
- +1 DO EN^AUPTFXX
- IF AUPTDIN&$DATA(^AUPTFXD(AUPTPSFL,AUPTPSFD))
- DO GET^AUPTFXD
- +2 QUIT
