PXQFV ;ISL/ARS,JVS - DEPENDENT ENTRY COUNT-VISITS(AUPNVSIT) ;5/1/97 08:30
;;1.0;PCE PATIENT CARE ENCOUNTER;**4,29,205**;Aug 12, 1996;Build 6
;
DEC(VISIT,VISUAL,EXPAND) ;Test looking through DD to find fields pointing to the visit entries.
; VISIT=Visit ien to looked up and counted
; VISUAL= Set to 1 if you want and interactive display of what is found
; EXPAND= SET TO 1 TO EXPAND ENTRIES
;
; Look for file and field
;
N DD,BECKY,COUNT,FIELD,FILE,GET,PIECE,PX,REF,SNDPIECE,STOP,SUB,VAUGHN
N DEC,DECF,ENTRY,VAR
;
S DD="^DD"
S FILE=""
F S FILE=$O(@DD@(9000010,0,"PT",FILE)) Q:FILE="" D
.S FIELD=""
.F S FIELD=$O(@DD@(9000010,0,"PT",FILE,FIELD)) Q:FIELD="" D
..S VDD(FILE,FIELD)=""
D REF,QUE
K VDDN,VDDR
I $G(VISUAL) S VAR="COUNT= "_COUNT W $$RE^PXQUTL(VAR)
Q ""
;
REF ;Look for all of the regular cross references and other
;
S FILE="" F S FILE=$O(VDD(FILE)) Q:FILE="" D
.S FIELD="" F S FIELD=$O(VDD(FILE,FIELD)) Q:FIELD="" D
..D REG
K VDD
Q
;
REG ;Look for regular cross references
;
S STOP=0
I '$D(@DD@(FILE,FIELD,1)) S VDDN(FILE,FIELD)="" Q
S SUB=0 F S SUB=$O(@DD@(FILE,FIELD,1,SUB)) Q:SUB="" D
.S GET=$G(@DD@(FILE,FIELD,1,SUB,0)) D
.I $P(GET,"^",3)']"" S VDDR(FILE,SUB)=FILE_"^"_FIELD_"^"_SUB S STOP=1
.E S VDDN(FILE,FIELD)=""
Q
QUE ;CHECK OUT CROSS REFERENCE
;
N PFILE
W:($G(EXPAND)&('$G(BROKEN))) $$EXP("^AUPNVSIT(",VISIT)
S FILE="",FIELD="",STOP="",COUNT=0
F S FILE=$O(VDDR(FILE)) Q:FILE="" D
.S SUB=0,STOP="" F S SUB=$O(VDDR(FILE,SUB)) Q:SUB="" Q:STOP=1 S GET=$G(VDDR(FILE,SUB)) D
..S REF=$G(@DD@($P(GET,"^",1),$P(GET,"^",2),1,$P(GET,"^",3),1))
..I $P(REF,"""",1)["DA(1)" Q
..S PIECE=$P(REF," ",2)
..S SNDPIECE=$P(PIECE,"""",1,2)_""""
..S VAUGHN=$P(PIECE,"""",1,2)_""")"
..I $D(@VAUGHN) D S STOP=1
...S PX=SNDPIECE_",VISIT)"
...I $D(@PX) D
....I '$G(EXPAND) S BECKY=0 F S BECKY=$O(@PX@(BECKY)) Q:BECKY="" S COUNT=COUNT+1 S DEC=SNDPIECE_","_VISIT_","_BECKY S DECF=$$FILE(SNDPIECE,FILE) W:$G(VISUAL) $$RE^PXQUTL(DEC_" - - - - "_DECF) D
.....I $G(BROKEN),SNDPIECE["AUPNVCPT" S (DFN,PATIENT)=$P($G(^AUPNVCPT(BECKY,0)),"^",2)
.....I $G(BROKEN),SNDPIECE["SCE" S DATE=$P($G(^SCE(BECKY,0)),"^",1)
.....W:$G(EXPAND) $$EXP^PXQUTL(SNDPIECE,BECKY)
.....W:$G(PXQSOR) $$SOR(SNDPIECE,BECKY),$$SOR^PXQFE(SNDPIECE,BECKY)
.....W:$G(PXQAUDIT) $$AUDIT(SNDPIECE,BECKY)
....I $G(EXPAND) S BECKY=0 F S BECKY=$O(@PX@(BECKY)) Q:BECKY="" S COUNT=COUNT+1 S PFILE=$$FILE(SNDPIECE,FILE) W:$G(VISUAL) $$RE^PXQUTL(" "_PFILE_" ") D
.....W:$G(EXPAND) $$EXP^PXQUTL(SNDPIECE,BECKY)
.....W:$G(PXQSOR) $$SOR(SNDPIECE,BECKY),$$SOR^PXQFE(SNDPIECE,BECKY)
.....W:$G(PXQAUDIT) $$AUDIT(SNDPIECE,BECKY)
Q
LINE() ;
Q:'$G(PXQAUDIT) ""
W "- - - - -"
Q ""
AUDIT(ROOT,IEN) ;---AUDIT TRAIL OF ENTRIES
N I,REF,REF2,SOURCE,ACTION,PERSON,NOD,J
S REF=$P(ROOT,"""",1)_IEN_")"
S REF2=$P(ROOT,"""",1)_IEN
F S REF=$Q(@REF) Q:REF'[REF2 D
.I REF[",801" S NOD=$P(@REF,"^",2) Q:NOD']"" D
..;W "ACTION",?26,"SOURCE",?52,"PERSON"
..W $$RE^PXQUTL("ACTION SOURCE PERSON")
..F I=1:1:$L(NOD,";") S J=$P(NOD,";",I) Q:J']"" D
...Q:$P(J,"-",1)="" Q:'($D(^PX(839.7,$P(J,"-",1),0))#2) ;PX*1.0*205 added
...S SOURCE=$P(^PX(839.7,$P(J,"-",1),0),"^",1)
...S ACTION=$P($P(J,"-",2)," ",1) S ACTION=$S(ACTION="E":"EDIT",ACTION="A":"CREATED",1:"")
...S PERSON=$P(^VA(200,$P(J," ",2),0),"^",1)
...W $$RE^PXQUTL(""""_ACTION_""",?16,"""_SOURCE_""",?45,"""_PERSON_"""")
W $$RE^PXQUTL("___________________________________________________________")
Q ""
;----FUNCTIONS
SOR(ROOT,IEN) ;---EXPAND ENTRIES
N I,REF,REF2,PKG,SOR,ADD,EDT
;I ROOT["SCE",$P($G(^SCE(IEN,0)),"^",6)="",$G(PXQPRM)=1 D
;.W $$RE^PXQUTL(" ~~~~ERROR~~~")
;.W $$RE^PXQUTL("** There is more Than 1 PARENT OUTPATIENT ENCOUNTER pointing to the same VISIT**")
;.W $$RE^PXQUTL(" ")
;I ROOT["SCE",$P($G(^SCE(IEN,0)),"^",6)="" S PXQPRM=1
S (PKG,SOR)=""
S REF=$P(ROOT,"""",1)_IEN_")"
S REF2=$P(ROOT,"""",1)_IEN
F S REF=$Q(@REF) Q:REF'[REF2 D
.I REF[",812" S PKG=$P(@REF,"^",2),SOR=$P(@REF,"^",3) D
..I PKG>0,$D(^DIC(9.4,$G(PKG))) S PKG=$P(^DIC(9.4,$G(PKG),0),"^",1)
..I SOR>0 S SOR=$P(^PX(839.7,$G(SOR),0),"^",1)
..S PKG="PACKAGE ="_$G(PKG)
..W $$RE^PXQUTL(PKG)
..S SOR="SOURCE ="_$G(SOR)
..W $$RE^PXQUTL(SOR)
S (PKG,SOR)=""
K ADD,EDT
Q ""
EXP(ROOT,IEN) ;---EXPAND ENTRIES
N I,REF,REF2
S REF=$P(ROOT,"""",1)_IEN_")"
S REF2=$P(ROOT,"""",1)_IEN
F S REF=$Q(@REF) Q:REF'[REF2 S ENTRY=REF_" = "_@REF W $$RE^PXQUTL(ENTRY)
I '$G(PXQSOR) W $$RE^PXQUTL("___")
I REF["AUPNVSIT" W $$RE^PXQUTL(" ")
Q ""
FILE(RT,FILENUM) ;
N FILE S FILE=""
I '$D(FILENUM) Q "UNKNOWN"
FF I $D(^DIC(FILENUM)) D
.S FILE=$P($G(^DIC(FILENUM,0)),"^",1)
E I $D(^DD(FILENUM)) S FILENUM=+$G(^DD(FILENUM,0,"UP")) G FF
Q FILE_" FILE"
PL ;--CHECK PAGE LENGTH
N ANS,DX,DY
I IOST["C-",$Y>22 S DX=0,DY=0 X ^%ZOSF("XY") R !,"Press ENTER to continue: ",ANS:DTIME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXQFV 5026 printed Dec 13, 2024@02:30:02 Page 2
PXQFV ;ISL/ARS,JVS - DEPENDENT ENTRY COUNT-VISITS(AUPNVSIT) ;5/1/97 08:30
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**4,29,205**;Aug 12, 1996;Build 6
+2 ;
DEC(VISIT,VISUAL,EXPAND) ;Test looking through DD to find fields pointing to the visit entries.
+1 ; VISIT=Visit ien to looked up and counted
+2 ; VISUAL= Set to 1 if you want and interactive display of what is found
+3 ; EXPAND= SET TO 1 TO EXPAND ENTRIES
+4 ;
+5 ; Look for file and field
+6 ;
+7 NEW DD,BECKY,COUNT,FIELD,FILE,GET,PIECE,PX,REF,SNDPIECE,STOP,SUB,VAUGHN
+8 NEW DEC,DECF,ENTRY,VAR
+9 ;
+10 SET DD="^DD"
+11 SET FILE=""
+12 FOR
SET FILE=$ORDER(@DD@(9000010,0,"PT",FILE))
if FILE=""
QUIT
Begin DoDot:1
+13 SET FIELD=""
+14 FOR
SET FIELD=$ORDER(@DD@(9000010,0,"PT",FILE,FIELD))
if FIELD=""
QUIT
Begin DoDot:2
+15 SET VDD(FILE,FIELD)=""
End DoDot:2
End DoDot:1
+16 DO REF
DO QUE
+17 KILL VDDN,VDDR
+18 IF $GET(VISUAL)
SET VAR="COUNT= "_COUNT
WRITE $$RE^PXQUTL(VAR)
+19 QUIT ""
+20 ;
REF ;Look for all of the regular cross references and other
+1 ;
+2 SET FILE=""
FOR
SET FILE=$ORDER(VDD(FILE))
if FILE=""
QUIT
Begin DoDot:1
+3 SET FIELD=""
FOR
SET FIELD=$ORDER(VDD(FILE,FIELD))
if FIELD=""
QUIT
Begin DoDot:2
+4 DO REG
End DoDot:2
End DoDot:1
+5 KILL VDD
+6 QUIT
+7 ;
REG ;Look for regular cross references
+1 ;
+2 SET STOP=0
+3 IF '$DATA(@DD@(FILE,FIELD,1))
SET VDDN(FILE,FIELD)=""
QUIT
+4 SET SUB=0
FOR
SET SUB=$ORDER(@DD@(FILE,FIELD,1,SUB))
if SUB=""
QUIT
Begin DoDot:1
+5 SET GET=$GET(@DD@(FILE,FIELD,1,SUB,0))
Begin DoDot:2
End DoDot:2
+6 IF $PIECE(GET,"^",3)']""
SET VDDR(FILE,SUB)=FILE_"^"_FIELD_"^"_SUB
SET STOP=1
+7 IF '$TEST
SET VDDN(FILE,FIELD)=""
End DoDot:1
+8 QUIT
QUE ;CHECK OUT CROSS REFERENCE
+1 ;
+2 NEW PFILE
+3 if ($GET(EXPAND)&('$GET(BROKEN)))
WRITE $$EXP("^AUPNVSIT(",VISIT)
+4 SET FILE=""
SET FIELD=""
SET STOP=""
SET COUNT=0
+5 FOR
SET FILE=$ORDER(VDDR(FILE))
if FILE=""
QUIT
Begin DoDot:1
+6 SET SUB=0
SET STOP=""
FOR
SET SUB=$ORDER(VDDR(FILE,SUB))
if SUB=""
QUIT
if STOP=1
QUIT
SET GET=$GET(VDDR(FILE,SUB))
Begin DoDot:2
+7 SET REF=$GET(@DD@($PIECE(GET,"^",1),$PIECE(GET,"^",2),1,$PIECE(GET,"^",3),1))
+8 IF $PIECE(REF,"""",1)["DA(1)"
QUIT
+9 SET PIECE=$PIECE(REF," ",2)
+10 SET SNDPIECE=$PIECE(PIECE,"""",1,2)_""""
+11 SET VAUGHN=$PIECE(PIECE,"""",1,2)_""")"
+12 IF $DATA(@VAUGHN)
Begin DoDot:3
+13 SET PX=SNDPIECE_",VISIT)"
+14 IF $DATA(@PX)
Begin DoDot:4
+15 IF '$GET(EXPAND)
SET BECKY=0
FOR
SET BECKY=$ORDER(@PX@(BECKY))
if BECKY=""
QUIT
SET COUNT=COUNT+1
SET DEC=SNDPIECE_","_VISIT_","_BECKY
SET DECF=$$FILE(SNDPIECE,FILE)
if $GET(VISUAL)
WRITE $$RE^PXQUTL(DEC_" - - - - "_DECF)
Begin DoDot:5
+16 IF $GET(BROKEN)
IF SNDPIECE["AUPNVCPT"
SET (DFN,PATIENT)=$PIECE($GET(^AUPNVCPT(BECKY,0)),"^",2)
+17 IF $GET(BROKEN)
IF SNDPIECE["SCE"
SET DATE=$PIECE($GET(^SCE(BECKY,0)),"^",1)
+18 if $GET(EXPAND)
WRITE $$EXP^PXQUTL(SNDPIECE,BECKY)
+19 if $GET(PXQSOR)
WRITE $$SOR(SNDPIECE,BECKY),$$SOR^PXQFE(SNDPIECE,BECKY)
+20 if $GET(PXQAUDIT)
WRITE $$AUDIT(SNDPIECE,BECKY)
End DoDot:5
+21 IF $GET(EXPAND)
SET BECKY=0
FOR
SET BECKY=$ORDER(@PX@(BECKY))
if BECKY=""
QUIT
SET COUNT=COUNT+1
SET PFILE=$$FILE(SNDPIECE,FILE)
if $GET(VISUAL)
WRITE $$RE^PXQUTL(" "_PFILE_" ")
Begin DoDot:5
+22 if $GET(EXPAND)
WRITE $$EXP^PXQUTL(SNDPIECE,BECKY)
+23 if $GET(PXQSOR)
WRITE $$SOR(SNDPIECE,BECKY),$$SOR^PXQFE(SNDPIECE,BECKY)
+24 if $GET(PXQAUDIT)
WRITE $$AUDIT(SNDPIECE,BECKY)
End DoDot:5
End DoDot:4
End DoDot:3
SET STOP=1
End DoDot:2
End DoDot:1
+25 QUIT
LINE() ;
+1 if '$GET(PXQAUDIT)
QUIT ""
+2 WRITE "- - - - -"
+3 QUIT ""
AUDIT(ROOT,IEN) ;---AUDIT TRAIL OF ENTRIES
+1 NEW I,REF,REF2,SOURCE,ACTION,PERSON,NOD,J
+2 SET REF=$PIECE(ROOT,"""",1)_IEN_")"
+3 SET REF2=$PIECE(ROOT,"""",1)_IEN
+4 FOR
SET REF=$QUERY(@REF)
if REF'[REF2
QUIT
Begin DoDot:1
+5 IF REF[",801"
SET NOD=$PIECE(@REF,"^",2)
if NOD']""
QUIT
Begin DoDot:2
+6 ;W "ACTION",?26,"SOURCE",?52,"PERSON"
+7 WRITE $$RE^PXQUTL("ACTION SOURCE PERSON")
+8 FOR I=1:1:$LENGTH(NOD,";")
SET J=$PIECE(NOD,";",I)
if J']""
QUIT
Begin DoDot:3
+9 ;PX*1.0*205 added
if $PIECE(J,"-",1)=""
QUIT
if '($DATA(^PX(839.7,$PIECE(J,"-",1),0))#2)
QUIT
+10 SET SOURCE=$PIECE(^PX(839.7,$PIECE(J,"-",1),0),"^",1)
+11 SET ACTION=$PIECE($PIECE(J,"-",2)," ",1)
SET ACTION=$SELECT(ACTION="E":"EDIT",ACTION="A":"CREATED",1:"")
+12 SET PERSON=$PIECE(^VA(200,$PIECE(J," ",2),0),"^",1)
+13 WRITE $$RE^PXQUTL(""""_ACTION_""",?16,"""_SOURCE_""",?45,"""_PERSON_"""")
End DoDot:3
End DoDot:2
End DoDot:1
+14 WRITE $$RE^PXQUTL("___________________________________________________________")
+15 QUIT ""
+16 ;----FUNCTIONS
SOR(ROOT,IEN) ;---EXPAND ENTRIES
+1 NEW I,REF,REF2,PKG,SOR,ADD,EDT
+2 ;I ROOT["SCE",$P($G(^SCE(IEN,0)),"^",6)="",$G(PXQPRM)=1 D
+3 ;.W $$RE^PXQUTL(" ~~~~ERROR~~~")
+4 ;.W $$RE^PXQUTL("** There is more Than 1 PARENT OUTPATIENT ENCOUNTER pointing to the same VISIT**")
+5 ;.W $$RE^PXQUTL(" ")
+6 ;I ROOT["SCE",$P($G(^SCE(IEN,0)),"^",6)="" S PXQPRM=1
+7 SET (PKG,SOR)=""
+8 SET REF=$PIECE(ROOT,"""",1)_IEN_")"
+9 SET REF2=$PIECE(ROOT,"""",1)_IEN
+10 FOR
SET REF=$QUERY(@REF)
if REF'[REF2
QUIT
Begin DoDot:1
+11 IF REF[",812"
SET PKG=$PIECE(@REF,"^",2)
SET SOR=$PIECE(@REF,"^",3)
Begin DoDot:2
+12 IF PKG>0
IF $DATA(^DIC(9.4,$GET(PKG)))
SET PKG=$PIECE(^DIC(9.4,$GET(PKG),0),"^",1)
+13 IF SOR>0
SET SOR=$PIECE(^PX(839.7,$GET(SOR),0),"^",1)
+14 SET PKG="PACKAGE ="_$GET(PKG)
+15 WRITE $$RE^PXQUTL(PKG)
+16 SET SOR="SOURCE ="_$GET(SOR)
+17 WRITE $$RE^PXQUTL(SOR)
End DoDot:2
End DoDot:1
+18 SET (PKG,SOR)=""
+19 KILL ADD,EDT
+20 QUIT ""
EXP(ROOT,IEN) ;---EXPAND ENTRIES
+1 NEW I,REF,REF2
+2 SET REF=$PIECE(ROOT,"""",1)_IEN_")"
+3 SET REF2=$PIECE(ROOT,"""",1)_IEN
+4 FOR
SET REF=$QUERY(@REF)
if REF'[REF2
QUIT
SET ENTRY=REF_" = "_@REF
WRITE $$RE^PXQUTL(ENTRY)
+5 IF '$GET(PXQSOR)
WRITE $$RE^PXQUTL("___")
+6 IF REF["AUPNVSIT"
WRITE $$RE^PXQUTL(" ")
+7 QUIT ""
FILE(RT,FILENUM) ;
+1 NEW FILE
SET FILE=""
+2 IF '$DATA(FILENUM)
QUIT "UNKNOWN"
FF IF $DATA(^DIC(FILENUM))
Begin DoDot:1
+1 SET FILE=$PIECE($GET(^DIC(FILENUM,0)),"^",1)
End DoDot:1
+2 IF '$TEST
IF $DATA(^DD(FILENUM))
SET FILENUM=+$GET(^DD(FILENUM,0,"UP"))
GOTO FF
+3 QUIT FILE_" FILE"
PL ;--CHECK PAGE LENGTH
+1 NEW ANS,DX,DY
+2 IF IOST["C-"
IF $Y>22
SET DX=0
SET DY=0
XECUTE ^%ZOSF("XY")
READ !,"Press ENTER to continue: ",ANS:DTIME
+3 QUIT
