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

BPMPTR.m

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