BPMPTR ;IHS/PHXAO/AEF - FIND POINTERS TO FILE ENTRY
;;1.0;IHS PATIENT MERGE;;MAR 01, 2010
;IHS/OIT/LJF 11/15/2006 routine originated from Phoenix Area Office
; changed namespace from BZXM to BPM
; changed code dealing with DUZ(2) global subscripts
;;
DESC ;----- ROUTINE DESCRIPTION
;;
;;THIS ROUTINE SEARCHES THE RPMS DATABASE FOR ALL POINTERS POINTING TO
;;THE SPECIFIED ENTRY IN THE SPECIFIED FILE. A REPORT OF THESE
;;POINTERS IS PRINTED. THIS ROUTINE CAN TAKE A LONG TIME TO RUN AND
;;USE A LOT OF PAPER.
;;
;;Reading the output from right to left, the right-most column is
;;the IEN or pointer value, the next column to the left is the DA,
;;the next one to the left is the DA(1), next is DA(2)... In some
;;cases, the left-most column will be the DUZ(2).
;;
;;$$END
;
N I,X F I=1:1 S X=$P($T(DESC+I),";;",2) Q:X["$$END" D EN^DDIOL(X)
Q
EN ;EP -- MAIN ENTRY POINT
;
N FILE,TITLE,VAL,ZTDESC,ZTRTN,ZTSAVE
;
D ^XBKVAR
D HOME^%ZIS
;
D DESC
;
D FILE(.FILE)
S FILE=+FILE
Q:'FILE
;
D VAL(.VAL)
S VAL=+VAL
Q:'VAL
;
S ZTRTN="DQ^BPMPTR"
S ZTDESC="POINTER REPORT"
S ZTSAVE("FILE")=""
S ZTSAVE("VAL")=""
D QUE(ZTRTN,.ZTSAVE,ZTDESC)
Q
DQ ;EP -- QUEUED JOB ENTRY POINT
;
; INPUT:
; FILE = POINTED TO FILE
; VAL = POINTER VALUE TO FIND
;
D ^XBKVAR
;
Q:'FILE
Q:'VAL
D FIND(FILE,VAL)
K FILE,VAL
D ^%ZISC
Q
FIND(FILE,VAL) ;EP
;----- FIND POINTERS TO FILE
; LOOPS THROUGH EACH POINTER FILE IN "PT" NODE OF DD
;
N CNT,OUT,PAGE,PFILE,PFLD,TCNT
;
S PAGE=0
S OUT=0
;
D HDR(FILE,VAL,.PAGE,.OUT)
Q:$G(OUT)
;
S CNT=0
S TCNT=0
;
S PFILE=0
F S PFILE=$O(^DD(FILE,0,"PT",PFILE)) Q:PFILE'>0 D Q:OUT
. S PFLD=0
. F S PFLD=$O(^DD(FILE,0,"PT",PFILE,PFLD)) Q:'PFLD D Q:OUT
. . D PTR(FILE,VAL,PFILE,PFLD,.TCNT,.CNT,.PAGE,.OUT)
;
W !,TCNT," POINTERS FOUND"
Q
PTR(FILE,VAL,PFILE,PFLD,TCNT,CNT,PAGE,OUT) ;
;----- LOOK AT POINTER FIELDS
; FOR ONE INDIVIDUAL POINTER FILE
;
; INPUT:
; FILE = FILE BEING POINTED TO
; VAL = POINTER INTERNAL VALUE TO FIND
; PFILE = FILE DOING THE POINTING
; PFLD = POINTER FIELD
;
N GR,DUZ2,L,LVL,TXT
;
D LVL(FILE,PFILE,PFLD,.LVL,.TXT)
S GR=$P(LVL($O(LVL(9999),-1)),U,3)
S GR=$G(^DIC(GR,0,"GL"))
D L(GR,.LVL,.L)
D LOOP(GR,VAL,FILE,.L,TXT,.TCNT,.CNT,.PAGE,.OUT)
Q
LOOP(GR,VAL,FILE,L,TXT,TCNT,CNT,PAGE,OUT) ;
;----- RECURSIVE CODE TO LOOP THROUGH SUBFILE LEVELS AND FIND POINTER
; VALUE
;
; INPUT:
; GR = GLOBAL ROOT OF TOP LEVEL FILE DOING THE POINTING
; L = ARRAY CONTAINING SUBFILE INFORMATION
; VAL = POINTER INTERNAL VALUE TO FIND
;
;
N D,GBL,GBLD,PVAL
;
S CNT=$G(CNT)+1
I $Y>(IOSL-5) D HDR(FILE,VAL,.PAGE,.OUT)
Q:OUT
W !!,CNT_".",?5,TXT
I GR']"" D Q
. W !?5,"<FILE CORRUPTED!!!>"
;
I GR["DUZ(2)" D Q
. S GBLD=$P(GR,"DUZ(2)")
. S DUZ2=0
. S GBLD=GBLD_DUZ2_")"
. F S DUZ2=$O(@GBLD) Q:'DUZ2 D Q:OUT
. . S $P(L(0),U,4)=""
. . S GBLD=$P(GR,"DUZ(2)")_DUZ2_")"
. . D L1
. S DUZ2=DUZ(2)
;
L1 ;
S L=""
F Q:+L<0 S L=$O(L(L)) Q:L']"" D L2 Q:+L<0 Q:OUT
Q
L2 ;
;
Q:+L<0
Q:OUT
S GBL=U_$P(L(L),U,3)_+$P(L(L),U,4)_")"
S D(L)=$O(@GBL)
I '+D(L) S $P(L(L),U,4)="" S L=L-1 G L2
S $P(L(L),U,4)=D(L)
Q:$O(L(L))
S GBL=U_$P(L(L),U,3)_+$P(L(L),U,4)_","_$P($P(L(0),U),";")_")"
S PVAL=$P($G(@GBL),U,$P($P(L(0),U),";",2))
I +PVAL=VAL D
. I $P(PVAL,";",2)]"",$P(PVAL,";",2)'=$P(^DIC(FILE,0,"GL"),U,2) Q
. D WRITE(PVAL,.L,.TCNT,FILE,.PAGE,.OUT)
G L2
Q
WRITE(VAL,L,TCNT,FILE,PAGE,OUT) ;
;----- WRITE RESULTS
;
N X
W !
I $G(DUZ2) D
. I $Y>(IOSL-5) D HDR(FILE,VAL,.PAGE,.OUT)
. Q:OUT
. W " "_DUZ2
Q:OUT
S X=""
F S X=$O(L(X)) Q:X']"" D Q:OUT
. I $Y>(IOSL-5) D HDR(FILE,VAL,.PAGE,.OUT)
. Q:OUT
. W " "_$P(L(X),U,4)
Q:OUT
W " "_VAL
S TCNT=$G(TCNT)+1
Q
LVL(FILE,PFILE,PFLD,LVL,TXT) ;
;----- SET UP LVL ARRAY CONTAINING POINTER FIELDS
;
; RETURNS LVL ARRAY AND TXT VARIABLE
;
; SETS LVL ARRAY:
; LVL(CNT)=TEXT^DX^SUBFILE#^UPFILE#^GLOBLOC
; WHERE: DX = THE "D" LEVEL AS IN D0,D1,D2,D3...
; GLOBLOC = SUBSCRIPT;NODE I.E., 1;0
; EXAMPLE:
; LVL(0)="PATIENT field (#.01)^4^^.01^0;1"
; LVL(1)="PATIENT sub-field (#50.806)^3^50.806^50.805^1;0"
; LVL(2)="IV DRUG sub-field (#50.805)^2^50.805^50.803^2;0"
; LVL(3)="DATE sub-field (#50.803)^1^50.803^50.8^2;0"
; LVL(4)="IV STATS File (#50.8)^0^50.8"
;
N CNT,FLD,I,N,SFILE,SS,UP,X
K LVL
;
S TXT=""
S CNT=0
S LVL(0)=$P($G(^DD(PFILE,PFLD,0)),U)_" field (#"_PFLD_")"_U_0_U_U_PFLD_U_$P($G(^DD(PFILE,PFLD,0)),U,4)
S $P(LVL(0),U,5)=$$NP($P(LVL(0),U,5))
S SFILE=PFILE
F D Q:'UP
. S UP=$G(^DD(SFILE,0,"UP"))
. Q:'UP
. S CNT=CNT+1
. S X=$P($G(^DD(SFILE,0)),U)
. S X=$P(X,"SUB-FIELD")_"sub-field (#"_SFILE_")"
. S FLD=$O(^DD(UP,"SB",SFILE,0))
. I FLD']"" D Q
. . W !!?5,"<<< MISSING DATA IN '^DD("_UP_","_"""SB"""_","_SFILE_",0)' NODE! >>>"
. . S SFILE=UP
. S SS=$P(^DD(UP,FLD,0),U,4)
. S LVL(CNT)=X_U_U_SFILE_U_UP_U_SS
. S $P(LVL(CNT),U,5)=$$NP($P(LVL(CNT),U,5))
. S SFILE=UP
S I=""
F S I=$O(LVL(I)) Q:I']"" D
. S $P(LVL(I),U,2)=(0-(I-(CNT+1)))
. S X=$P(LVL(I),U)
. S TXT=TXT_$S(TXT]"":" of the ",1:"")_X
S CNT=CNT+1
S LVL(CNT)=$O(^DD(SFILE,0,"NM",""))_" File (#"_SFILE_")"_U_0_U_SFILE
S TXT=TXT_" of the "_$P(LVL(CNT),U)
Q
L(GR,LVL,L) ;
;----- SET UP L(X) ARRAY
;
; L ARRAY CONTAINS NODE, PIECE, AND SUBFILE SUBSCRIPT LEVEL DATA
; WHERE POINTER VALUE IS STORED
; PIECE 1 = NODE;PIECE
; PIECE 2 = "D" LEVEL, I.E., D0,D1,D2,D3...
; PIECE 3 = SUBSCRIPT LEVELS
;
; EXAMPLE:
; L(0)="0;1^D(0)^PS(50.8,"
; L(1)="2;0^D(1)^PS(50.8,D(0),2,"
; L(2)="2;0^D(2)^PS(50.8,D(0),2,D(1),2,"
; L(3)="1;0^D(3)^PS(50.8,D(0),2,D(1),2,D(2),1,"
;
N LASTL
;
S L=0
F S L=$O(LVL(L)) Q:'L D
. Q:LVL(L)'["sub-field"
. S L($P(LVL(L),U,2))=$P(LVL(L),U,5)_U_"D("_$P(LVL(L),U,2)_")"
S L(0)=$P(LVL(0),U,5)_U_"D(0)"_U_$P(GR,U,2)
;
S $P(L(0),U,3)=$P(GR,U,2)
S L=0
F S L=$O(L(L)) Q:L']"" D
. S GR=GR_$P(L(L-1),U,2)_","_$P($P(L(L),U),";")_","
. S $P(L(L),U,3)=$P(GR,U,2)
. S LASTL=L
Q
;
FILE(FILE) ;
;----- PROMPT FOR FILE CONTAINING THE POINTED TO ENTRY
;
N DIC,DTOUT,DUOUT,X,Y
;
S FILE=0
S DIC="^DIC("
S DIC(0)="AEMQ"
S DIC("A")="Select 'POINTED TO' file: "
S DIC("B")="VA PATIENT"
S DIC("?")="The file that is being pointed to by other files"
D ^DIC
I $D(DTOUT)!($D(DUOUT))!(+Y'>0) Q
S FILE=+Y
Q
;
VAL(VAL) ;
;----- PROMPT FOR POINTER VALUE
;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
;
S VAL=0
S DIR(0)="N"
S DIR("A")="Select INTERNAL POINTER VALUE to find"
S DIR("?")="EXAMPLE: Patient DFN"
D ^DIR
I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(+Y'>0) Q
S VAL=+Y
Q
;
QUE(ZTRTN,ZTSAVE,ZTDESC) ;
;----- QUEUEING CODE
;
N %ZIS,IO,POP,ZTIO,ZTSK
S %ZIS="Q"
D ^%ZIS
Q:POP
I $D(IO("Q")) D Q
. K IO("Q")
. S ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
. D ^%ZTLOAD
. I $G(ZTSK) W !,"Task #",$G(TASK)," queued"
D @ZTRTN
Q
;
HDR(FILE,VAL,PAGE,OUT) ;
;----- WRITE HEADER
;
N DIR,DIRUT,DTOUT,DUOUT,I,X,Y
;
I $E(IOST)="C",$G(PAGE) D
. S DIR(0)="E"
. D ^DIR
. K DIR
. I 'Y S OUT=1
Q:OUT
;
S PAGE=$G(PAGE)+1
W @IOF
W !,"Pointers to IEN #"_VAL_" in the "_$P(^DIC(FILE,0),U)_" file #"_FILE
W !?49,$$NOW
W " PAGE ",PAGE
W !
F I=1:1:IOM W "-"
W !
Q
NP(X) ;----- PUT QUOTES AROUND ALPHA NODE
;
; INPUT:
; X = NODE;PIECE, I.E., SCLR;13
;
N N,Y
S Y=X
S N=$P(Y,";")
I N'=+N D
. S N=""""_N_""""
. S $P(Y,";")=N
Q Y
NOW() ;
;----- RETURNS TODAY'S DATE/TIME
;
N %,%H,%I,X
D NOW^%DTC
S Y=DT
X ^DD("DD")
Q Y_" "_$E($P(%,".",2),1,2)_":"_$E($P(%,".",2),3,4)
BPMPTR ;IHS/PHXAO/AEF - FIND POINTERS TO FILE ENTRY
+1 ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010
+2 ;IHS/OIT/LJF 11/15/2006 routine originated from Phoenix Area Office
+3 ; changed namespace from BZXM to BPM
+4 ; changed code dealing with DUZ(2) global subscripts
+5 ;;
DESC ;----- ROUTINE DESCRIPTION
+1 ;;
+2 ;;THIS ROUTINE SEARCHES THE RPMS DATABASE FOR ALL POINTERS POINTING TO
+3 ;;THE SPECIFIED ENTRY IN THE SPECIFIED FILE. A REPORT OF THESE
+4 ;;POINTERS IS PRINTED. THIS ROUTINE CAN TAKE A LONG TIME TO RUN AND
+5 ;;USE A LOT OF PAPER.
+6 ;;
+7 ;;Reading the output from right to left, the right-most column is
+8 ;;the IEN or pointer value, the next column to the left is the DA,
+9 ;;the next one to the left is the DA(1), next is DA(2)... In some
+10 ;;cases, the left-most column will be the DUZ(2).
+11 ;;
+12 ;;$$END
+13 ;
+14 NEW I,X
FOR I=1:1
SET X=$PIECE($TEXT(DESC+I),";;",2)
IF X["$$END"
QUIT
DO EN^DDIOL(X)
+15 QUIT
EN ;EP -- MAIN ENTRY POINT
+1 ;
+2 NEW FILE,TITLE,VAL,ZTDESC,ZTRTN,ZTSAVE
+3 ;
+4 DO ^XBKVAR
+5 DO HOME^%ZIS
+6 ;
+7 DO DESC
+8 ;
+9 DO FILE(.FILE)
+10 SET FILE=+FILE
+11 IF 'FILE
QUIT
+12 ;
+13 DO VAL(.VAL)
+14 SET VAL=+VAL
+15 IF 'VAL
QUIT
+16 ;
+17 SET ZTRTN="DQ^BPMPTR"
+18 SET ZTDESC="POINTER REPORT"
+19 SET ZTSAVE("FILE")=""
+20 SET ZTSAVE("VAL")=""
+21 DO QUE(ZTRTN,.ZTSAVE,ZTDESC)
+22 QUIT
DQ ;EP -- QUEUED JOB ENTRY POINT
+1 ;
+2 ; INPUT:
+3 ; FILE = POINTED TO FILE
+4 ; VAL = POINTER VALUE TO FIND
+5 ;
+6 DO ^XBKVAR
+7 ;
+8 IF 'FILE
QUIT
+9 IF 'VAL
QUIT
+10 DO FIND(FILE,VAL)
+11 KILL FILE,VAL
+12 DO ^%ZISC
+13 QUIT
FIND(FILE,VAL) ;EP
+1 ;----- FIND POINTERS TO FILE
+2 ; LOOPS THROUGH EACH POINTER FILE IN "PT" NODE OF DD
+3 ;
+4 NEW CNT,OUT,PAGE,PFILE,PFLD,TCNT
+5 ;
+6 SET PAGE=0
+7 SET OUT=0
+8 ;
+9 DO HDR(FILE,VAL,.PAGE,.OUT)
+10 IF $GET(OUT)
QUIT
+11 ;
+12 SET CNT=0
+13 SET TCNT=0
+14 ;
+15 SET PFILE=0
+16 FOR
SET PFILE=$ORDER(^DD(FILE,0,"PT",PFILE))
IF PFILE'>0
QUIT
Begin DoDot:1
+17 SET PFLD=0
+18 FOR
SET PFLD=$ORDER(^DD(FILE,0,"PT",PFILE,PFLD))
IF 'PFLD
QUIT
Begin DoDot:2
+19 DO PTR(FILE,VAL,PFILE,PFLD,.TCNT,.CNT,.PAGE,.OUT)
End DoDot:2
IF OUT
QUIT
End DoDot:1
IF OUT
QUIT
+20 ;
+21 WRITE !,TCNT," POINTERS FOUND"
+22 QUIT
PTR(FILE,VAL,PFILE,PFLD,TCNT,CNT,PAGE,OUT) ;
+1 ;----- LOOK AT POINTER FIELDS
+2 ; FOR ONE INDIVIDUAL POINTER FILE
+3 ;
+4 ; INPUT:
+5 ; FILE = FILE BEING POINTED TO
+6 ; VAL = POINTER INTERNAL VALUE TO FIND
+7 ; PFILE = FILE DOING THE POINTING
+8 ; PFLD = POINTER FIELD
+9 ;
+10 NEW GR,DUZ2,L,LVL,TXT
+11 ;
+12 DO LVL(FILE,PFILE,PFLD,.LVL,.TXT)
+13 SET GR=$PIECE(LVL($ORDER(LVL(9999),-1)),U,3)
+14 SET GR=$GET(^DIC(GR,0,"GL"))
+15 DO L(GR,.LVL,.L)
+16 DO LOOP(GR,VAL,FILE,.L,TXT,.TCNT,.CNT,.PAGE,.OUT)
+17 QUIT
LOOP(GR,VAL,FILE,L,TXT,TCNT,CNT,PAGE,OUT) ;
+1 ;----- RECURSIVE CODE TO LOOP THROUGH SUBFILE LEVELS AND FIND POINTER
+2 ; VALUE
+3 ;
+4 ; INPUT:
+5 ; GR = GLOBAL ROOT OF TOP LEVEL FILE DOING THE POINTING
+6 ; L = ARRAY CONTAINING SUBFILE INFORMATION
+7 ; VAL = POINTER INTERNAL VALUE TO FIND
+8 ;
+9 ;
+10 NEW D,GBL,GBLD,PVAL
+11 ;
+12 SET CNT=$GET(CNT)+1
+13 IF $Y>(IOSL-5)
DO HDR(FILE,VAL,.PAGE,.OUT)
+14 IF OUT
QUIT
+15 WRITE !!,CNT_".",?5,TXT
+16 IF GR']""
Begin DoDot:1
+17 WRITE !?5,"<FILE CORRUPTED!!!>"
End DoDot:1
QUIT
+18 ;
+19 IF GR["DUZ(2)"
Begin DoDot:1
+20 SET GBLD=$PIECE(GR,"DUZ(2)")
+21 SET DUZ2=0
+22 SET GBLD=GBLD_DUZ2_")"
+23 FOR
SET DUZ2=$ORDER(@GBLD)
IF 'DUZ2
QUIT
Begin DoDot:2
+24 SET $PIECE(L(0),U,4)=""
+25 SET GBLD=$PIECE(GR,"DUZ(2)")_DUZ2_")"
+26 DO L1
End DoDot:2
IF OUT
QUIT
+27 SET DUZ2=DUZ(2)
End DoDot:1
QUIT
+28 ;
L1 ;
+1 SET L=""
+2 FOR
IF +L<0
QUIT
SET L=$ORDER(L(L))
IF L']""
QUIT
DO L2
IF +L<0
QUIT
IF OUT
QUIT
+3 QUIT
L2 ;
+1 ;
+2 IF +L<0
QUIT
+3 IF OUT
QUIT
+4 SET GBL=U_$PIECE(L(L),U,3)_+$PIECE(L(L),U,4)_")"
+5 SET D(L)=$ORDER(@GBL)
+6 IF '+D(L)
SET $PIECE(L(L),U,4)=""
SET L=L-1
GOTO L2
+7 SET $PIECE(L(L),U,4)=D(L)
+8 IF $ORDER(L(L))
QUIT
+9 SET GBL=U_$PIECE(L(L),U,3)_+$PIECE(L(L),U,4)_","_$PIECE($PIECE(L(0),U),";")_")"
+10 SET PVAL=$PIECE($GET(@GBL),U,$PIECE($PIECE(L(0),U),";",2))
+11 IF +PVAL=VAL
Begin DoDot:1
+12 IF $PIECE(PVAL,";",2)]""
IF $PIECE(PVAL,";",2)'=$PIECE(^DIC(FILE,0,"GL"),U,2)
QUIT
+13 DO WRITE(PVAL,.L,.TCNT,FILE,.PAGE,.OUT)
End DoDot:1
+14 GOTO L2
+15 QUIT
WRITE(VAL,L,TCNT,FILE,PAGE,OUT) ;
+1 ;----- WRITE RESULTS
+2 ;
+3 NEW X
+4 WRITE !
+5 IF $GET(DUZ2)
Begin DoDot:1
+6 IF $Y>(IOSL-5)
DO HDR(FILE,VAL,.PAGE,.OUT)
+7 IF OUT
QUIT
+8 WRITE " "_DUZ2
End DoDot:1
+9 IF OUT
QUIT
+10 SET X=""
+11 FOR
SET X=$ORDER(L(X))
IF X']""
QUIT
Begin DoDot:1
+12 IF $Y>(IOSL-5)
DO HDR(FILE,VAL,.PAGE,.OUT)
+13 IF OUT
QUIT
+14 WRITE " "_$PIECE(L(X),U,4)
End DoDot:1
IF OUT
QUIT
+15 IF OUT
QUIT
+16 WRITE " "_VAL
+17 SET TCNT=$GET(TCNT)+1
+18 QUIT
LVL(FILE,PFILE,PFLD,LVL,TXT) ;
+1 ;----- SET UP LVL ARRAY CONTAINING POINTER FIELDS
+2 ;
+3 ; RETURNS LVL ARRAY AND TXT VARIABLE
+4 ;
+5 ; SETS LVL ARRAY:
+6 ; LVL(CNT)=TEXT^DX^SUBFILE#^UPFILE#^GLOBLOC
+7 ; WHERE: DX = THE "D" LEVEL AS IN D0,D1,D2,D3...
+8 ; GLOBLOC = SUBSCRIPT;NODE I.E., 1;0
+9 ; EXAMPLE:
+10 ; LVL(0)="PATIENT field (#.01)^4^^.01^0;1"
+11 ; LVL(1)="PATIENT sub-field (#50.806)^3^50.806^50.805^1;0"
+12 ; LVL(2)="IV DRUG sub-field (#50.805)^2^50.805^50.803^2;0"
+13 ; LVL(3)="DATE sub-field (#50.803)^1^50.803^50.8^2;0"
+14 ; LVL(4)="IV STATS File (#50.8)^0^50.8"
+15 ;
+16 NEW CNT,FLD,I,N,SFILE,SS,UP,X
+17 KILL LVL
+18 ;
+19 SET TXT=""
+20 SET CNT=0
+21 SET LVL(0)=$PIECE($GET(^DD(PFILE,PFLD,0)),U)_" field (#"_PFLD_")"_U_0_U_U_PFLD_U_$PIECE($GET(^DD(PFILE,PFLD,0)),U,4)
+22 SET $PIECE(LVL(0),U,5)=$$NP($PIECE(LVL(0),U,5))
+23 SET SFILE=PFILE
+24 FOR
Begin DoDot:1
+25 SET UP=$GET(^DD(SFILE,0,"UP"))
+26 IF 'UP
QUIT
+27 SET CNT=CNT+1
+28 SET X=$PIECE($GET(^DD(SFILE,0)),U)
+29 SET X=$PIECE(X,"SUB-FIELD")_"sub-field (#"_SFILE_")"
+30 SET FLD=$ORDER(^DD(UP,"SB",SFILE,0))
+31 IF FLD']""
Begin DoDot:2
+32 WRITE !!?5,"<<< MISSING DATA IN '^DD("_UP_","_"""SB"""_","_SFILE_",0)' NODE! >>>"
+33 SET SFILE=UP
End DoDot:2
QUIT
+34 SET SS=$PIECE(^DD(UP,FLD,0),U,4)
+35 SET LVL(CNT)=X_U_U_SFILE_U_UP_U_SS
+36 SET $PIECE(LVL(CNT),U,5)=$$NP($PIECE(LVL(CNT),U,5))
+37 SET SFILE=UP
End DoDot:1
IF 'UP
QUIT
+38 SET I=""
+39 FOR
SET I=$ORDER(LVL(I))
IF I']""
QUIT
Begin DoDot:1
+40 SET $PIECE(LVL(I),U,2)=(0-(I-(CNT+1)))
+41 SET X=$PIECE(LVL(I),U)
+42 SET TXT=TXT_$SELECT(TXT]"":" of the ",1:"")_X
End DoDot:1
+43 SET CNT=CNT+1
+44 SET LVL(CNT)=$ORDER(^DD(SFILE,0,"NM",""))_" File (#"_SFILE_")"_U_0_U_SFILE
+45 SET TXT=TXT_" of the "_$PIECE(LVL(CNT),U)
+46 QUIT
L(GR,LVL,L) ;
+1 ;----- SET UP L(X) ARRAY
+2 ;
+3 ; L ARRAY CONTAINS NODE, PIECE, AND SUBFILE SUBSCRIPT LEVEL DATA
+4 ; WHERE POINTER VALUE IS STORED
+5 ; PIECE 1 = NODE;PIECE
+6 ; PIECE 2 = "D" LEVEL, I.E., D0,D1,D2,D3...
+7 ; PIECE 3 = SUBSCRIPT LEVELS
+8 ;
+9 ; EXAMPLE:
+10 ; L(0)="0;1^D(0)^PS(50.8,"
+11 ; L(1)="2;0^D(1)^PS(50.8,D(0),2,"
+12 ; L(2)="2;0^D(2)^PS(50.8,D(0),2,D(1),2,"
+13 ; L(3)="1;0^D(3)^PS(50.8,D(0),2,D(1),2,D(2),1,"
+14 ;
+15 NEW LASTL
+16 ;
+17 SET L=0
+18 FOR
SET L=$ORDER(LVL(L))
IF 'L
QUIT
Begin DoDot:1
+19 IF LVL(L)'["sub-field"
QUIT
+20 SET L($PIECE(LVL(L),U,2))=$PIECE(LVL(L),U,5)_U_"D("_$PIECE(LVL(L),U,2)_")"
End DoDot:1
+21 SET L(0)=$PIECE(LVL(0),U,5)_U_"D(0)"_U_$PIECE(GR,U,2)
+22 ;
+23 SET $PIECE(L(0),U,3)=$PIECE(GR,U,2)
+24 SET L=0
+25 FOR
SET L=$ORDER(L(L))
IF L']""
QUIT
Begin DoDot:1
+26 SET GR=GR_$PIECE(L(L-1),U,2)_","_$PIECE($PIECE(L(L),U),";")_","
+27 SET $PIECE(L(L),U,3)=$PIECE(GR,U,2)
+28 SET LASTL=L
End DoDot:1
+29 QUIT
+30 ;
FILE(FILE) ;
+1 ;----- PROMPT FOR FILE CONTAINING THE POINTED TO ENTRY
+2 ;
+3 NEW DIC,DTOUT,DUOUT,X,Y
+4 ;
+5 SET FILE=0
+6 SET DIC="^DIC("
+7 SET DIC(0)="AEMQ"
+8 SET DIC("A")="Select 'POINTED TO' file: "
+9 SET DIC("B")="VA PATIENT"
+10 SET DIC("?")="The file that is being pointed to by other files"
+11 DO ^DIC
+12 IF $DATA(DTOUT)!($DATA(DUOUT))!(+Y'>0)
QUIT
+13 SET FILE=+Y
+14 QUIT
+15 ;
VAL(VAL) ;
+1 ;----- PROMPT FOR POINTER VALUE
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+4 ;
+5 SET VAL=0
+6 SET DIR(0)="N"
+7 SET DIR("A")="Select INTERNAL POINTER VALUE to find"
+8 SET DIR("?")="EXAMPLE: Patient DFN"
+9 DO ^DIR
+10 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!(+Y'>0)
QUIT
+11 SET VAL=+Y
+12 QUIT
+13 ;
QUE(ZTRTN,ZTSAVE,ZTDESC) ;
+1 ;----- QUEUEING CODE
+2 ;
+3 NEW %ZIS,IO,POP,ZTIO,ZTSK
+4 SET %ZIS="Q"
+5 DO ^%ZIS
+6 IF POP
QUIT
+7 IF $DATA(IO("Q"))
Begin DoDot:1
+8 KILL IO("Q")
+9 SET ZTIO=ION_";"_IOST_";"_IOM_";"_IOSL
+10 DO ^%ZTLOAD
+11 IF $GET(ZTSK)
WRITE !,"Task #",$GET(TASK)," queued"
End DoDot:1
QUIT
+12 DO @ZTRTN
+13 QUIT
+14 ;
HDR(FILE,VAL,PAGE,OUT) ;
+1 ;----- WRITE HEADER
+2 ;
+3 NEW DIR,DIRUT,DTOUT,DUOUT,I,X,Y
+4 ;
+5 IF $EXTRACT(IOST)="C"
IF $GET(PAGE)
Begin DoDot:1
+6 SET DIR(0)="E"
+7 DO ^DIR
+8 KILL DIR
+9 IF 'Y
SET OUT=1
End DoDot:1
+10 IF OUT
QUIT
+11 ;
+12 SET PAGE=$GET(PAGE)+1
+13 WRITE @IOF
+14 WRITE !,"Pointers to IEN #"_VAL_" in the "_$PIECE(^DIC(FILE,0),U)_" file #"_FILE
+15 WRITE !?49,$$NOW
+16 WRITE " PAGE ",PAGE
+17 WRITE !
+18 FOR I=1:1:IOM
WRITE "-"
+19 WRITE !
+20 QUIT
NP(X) ;----- PUT QUOTES AROUND ALPHA NODE
+1 ;
+2 ; INPUT:
+3 ; X = NODE;PIECE, I.E., SCLR;13
+4 ;
+5 NEW N,Y
+6 SET Y=X
+7 SET N=$PIECE(Y,";")
+8 IF N'=+N
Begin DoDot:1
+9 SET N=""""_N_""""
+10 SET $PIECE(Y,";")=N
End DoDot:1
+11 QUIT Y
NOW() ;
+1 ;----- RETURNS TODAY'S DATE/TIME
+2 ;
+3 NEW %,%H,%I,X
+4 DO NOW^%DTC
+5 SET Y=DT
+6 XECUTE ^DD("DD")
+7 QUIT Y_" "_$EXTRACT($PIECE(%,".",2),1,2)_":"_$EXTRACT($PIECE(%,".",2),3,4)
