PXQFE ;ISL/JVS - DEPENDENT ENTRY COUNT-ENCOUNTERS (SCE) ;5/1/97 08:29
;;1.0;PCE PATIENT CARE ENCOUNTER;**4,29**;Aug 12, 1996
;
DEC(VISIT,VISUAL,EXPAND) ;Test looking through DD to find fields pointing to the visit entries.
; ENCOUNTER=ENCOUNTER 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 VAR,DEC,DECF,ORG,STS,TYP
;
S DD="^DD"
S FILE=""
F S FILE=$O(@DD@(409.68,0,"PT",FILE)) Q:FILE="" D
.S FIELD=""
.F S FIELD=$O(@DD@(409.68,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
;
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
....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
.....W:$G(EXPAND) $$EXP^PXQFV(SNDPIECE,BECKY)
.....W:$G(PXQSOR) $$SOR^PXQFE(SNDPIECE,BECKY)
Q
;
LINE() ;--LINE
Q:'$G(PXQAUDIT) ""
W "- - - - -"
Q ""
;
SOR(ROOT,IEN) ;--SOURCE OF ENCOUNTER
N I,REF,REF2,PKG,SOR
S REF=$P(ROOT,"""",1)_IEN_")"
S REF2=$P(ROOT,"""",1)_IEN
I REF["SCE" D
.S ORG=$P(^SCE(IEN,0),"^",8)
.S STS=$P(^SCE(IEN,0),"^",12) I STS>0 S STS=$P(^SD(409.63,STS,0),"^",1)
.S TYP=$P(^SCE(IEN,0),"^",10) I TYP>0 S TYP=$P(^SD(409.1,TYP,0),"^",1)
.W $$RE^PXQUTL("ORGINATING PROCESS = "_$S(ORG=1:"APPOINTMENT",ORG=2:"STOP CODE ADDITION",ORG=3:"DISPOSITION",ORG=4:"CREDIT STOP CODE",1:"**NOT STORED**"))
.W $$RE^PXQUTL(" CHECK-OUT STATUS = "_STS)
.W $$RE^PXQUTL(" APPOINTMENT TYPE = "_TYP)
.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"
PXQFE ;ISL/JVS - DEPENDENT ENTRY COUNT-ENCOUNTERS (SCE) ;5/1/97 08:29
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**4,29**;Aug 12, 1996
+2 ;
DEC(VISIT,VISUAL,EXPAND) ;Test looking through DD to find fields pointing to the visit entries.
+1 ; ENCOUNTER=ENCOUNTER 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 VAR,DEC,DECF,ORG,STS,TYP
+9 ;
+10 SET DD="^DD"
+11 SET FILE=""
+12 FOR
SET FILE=$ORDER(@DD@(409.68,0,"PT",FILE))
IF FILE=""
QUIT
Begin DoDot:1
+13 SET FIELD=""
+14 FOR
SET FIELD=$ORDER(@DD@(409.68,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 SET FILE=""
SET FIELD=""
SET STOP=""
SET COUNT=0
+3 FOR
SET FILE=$ORDER(VDDR(FILE))
IF FILE=""
QUIT
Begin DoDot:1
+4 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
+5 SET REF=$GET(@DD@($PIECE(GET,"^",1),$PIECE(GET,"^",2),1,$PIECE(GET,"^",3),1))
+6 IF $PIECE(REF,"""",1)["DA(1)"
QUIT
+7 SET PIECE=$PIECE(REF," ",2)
+8 SET SNDPIECE=$PIECE(PIECE,"""",1,2)_""""
+9 SET VAUGHN=$PIECE(PIECE,"""",1,2)_""")"
+10 IF $DATA(@VAUGHN)
Begin DoDot:3
+11 SET PX=SNDPIECE_",VISIT)"
+12 IF $DATA(@PX)
Begin DoDot:4
+13 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
+14 IF $GET(EXPAND)
WRITE $$EXP^PXQFV(SNDPIECE,BECKY)
+15 IF $GET(PXQSOR)
WRITE $$SOR^PXQFE(SNDPIECE,BECKY)
End DoDot:5
End DoDot:4
End DoDot:3
SET STOP=1
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
LINE() ;--LINE
+1 IF '$GET(PXQAUDIT)
QUIT ""
+2 WRITE "- - - - -"
+3 QUIT ""
+4 ;
SOR(ROOT,IEN) ;--SOURCE OF ENCOUNTER
+1 NEW I,REF,REF2,PKG,SOR
+2 SET REF=$PIECE(ROOT,"""",1)_IEN_")"
+3 SET REF2=$PIECE(ROOT,"""",1)_IEN
+4 IF REF["SCE"
Begin DoDot:1
+5 SET ORG=$PIECE(^SCE(IEN,0),"^",8)
+6 SET STS=$PIECE(^SCE(IEN,0),"^",12)
IF STS>0
SET STS=$PIECE(^SD(409.63,STS,0),"^",1)
+7 SET TYP=$PIECE(^SCE(IEN,0),"^",10)
IF TYP>0
SET TYP=$PIECE(^SD(409.1,TYP,0),"^",1)
+8 WRITE $$RE^PXQUTL("ORGINATING PROCESS = "_$SELECT(ORG=1:"APPOINTMENT",ORG=2:"STOP CODE ADDITION",ORG=3:"DISPOSITION",ORG=4:"CREDIT STOP CODE",1:"**NOT STORED**"))
+9 WRITE $$RE^PXQUTL(" CHECK-OUT STATUS = "_STS)
+10 WRITE $$RE^PXQUTL(" APPOINTMENT TYPE = "_TYP)
+11 WRITE $$RE^PXQUTL(" ")
End DoDot:1
+12 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"
