%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
