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

PXQFE.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. 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
  1. ; VISUAL= Set to 1 if you want and interactive display of what is found
  1. ; EXPAND= SET TO 1 TO EXPAND ENTRIES
  1. ;
  1. ; Look for file and field
  1. ;
  1. N DD,BECKY,COUNT,FIELD,FILE,GET,PIECE,PX,REF,SNDPIECE,STOP,SUB,VAUGHN
  1. N VAR,DEC,DECF,ORG,STS,TYP
  1. ;
  1. S DD="^DD"
  1. S FILE=""
  1. F S FILE=$O(@DD@(409.68,0,"PT",FILE)) Q:FILE="" D
  1. .S FIELD=""
  1. .F S FIELD=$O(@DD@(409.68,0,"PT",FILE,FIELD)) Q:FIELD="" D
  1. ..S VDD(FILE,FIELD)=""
  1. D REF,QUE
  1. K VDDN,VDDR
  1. I $G(VISUAL) S VAR="COUNT= "_COUNT W $$RE^PXQUTL(VAR)
  1. Q ""
  1. ;
  1. REF ;Look for all of the regular cross references and other
  1. ;
  1. S FILE="" F S FILE=$O(VDD(FILE)) Q:FILE="" D
  1. .S FIELD="" F S FIELD=$O(VDD(FILE,FIELD)) Q:FIELD="" D
  1. ..D REG
  1. K VDD
  1. Q
  1. ;
  1. REG ;Look for regular cross references
  1. ;
  1. S STOP=0
  1. I '$D(@DD@(FILE,FIELD,1)) S VDDN(FILE,FIELD)="" Q
  1. S SUB=0 F S SUB=$O(@DD@(FILE,FIELD,1,SUB)) Q:SUB="" D
  1. .S GET=$G(@DD@(FILE,FIELD,1,SUB,0)) D
  1. .I $P(GET,"^",3)']"" S VDDR(FILE,SUB)=FILE_"^"_FIELD_"^"_SUB S STOP=1
  1. .E S VDDN(FILE,FIELD)=""
  1. Q
  1. QUE ;CHECK OUT CROSS REFERENCE
  1. ;
  1. S FILE="",FIELD="",STOP="",COUNT=0
  1. F S FILE=$O(VDDR(FILE)) Q:FILE="" D
  1. .S SUB=0,STOP="" F S SUB=$O(VDDR(FILE,SUB)) Q:SUB="" Q:STOP=1 S GET=$G(VDDR(FILE,SUB)) D
  1. ..S REF=$G(@DD@($P(GET,"^",1),$P(GET,"^",2),1,$P(GET,"^",3),1))
  1. ..I $P(REF,"""",1)["DA(1)" Q
  1. ..S PIECE=$P(REF," ",2)
  1. ..S SNDPIECE=$P(PIECE,"""",1,2)_""""
  1. ..S VAUGHN=$P(PIECE,"""",1,2)_""")"
  1. ..I $D(@VAUGHN) D S STOP=1
  1. ...S PX=SNDPIECE_",VISIT)"
  1. ...I $D(@PX) D
  1. ....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
  1. .....W:$G(EXPAND) $$EXP^PXQFV(SNDPIECE,BECKY)
  1. .....W:$G(PXQSOR) $$SOR^PXQFE(SNDPIECE,BECKY)
  1. Q
  1. ;
  1. LINE() ;--LINE
  1. Q:'$G(PXQAUDIT) ""
  1. W "- - - - -"
  1. Q ""
  1. ;
  1. SOR(ROOT,IEN) ;--SOURCE OF ENCOUNTER
  1. N I,REF,REF2,PKG,SOR
  1. S REF=$P(ROOT,"""",1)_IEN_")"
  1. S REF2=$P(ROOT,"""",1)_IEN
  1. I REF["SCE" D
  1. .S ORG=$P(^SCE(IEN,0),"^",8)
  1. .S STS=$P(^SCE(IEN,0),"^",12) I STS>0 S STS=$P(^SD(409.63,STS,0),"^",1)
  1. .S TYP=$P(^SCE(IEN,0),"^",10) I TYP>0 S TYP=$P(^SD(409.1,TYP,0),"^",1)
  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**"))
  1. .W $$RE^PXQUTL(" CHECK-OUT STATUS = "_STS)
  1. .W $$RE^PXQUTL(" APPOINTMENT TYPE = "_TYP)
  1. .W $$RE^PXQUTL(" ")
  1. Q ""
  1. FILE(RT,FILENUM) ;
  1. N FILE S FILE=""
  1. I '$D(FILENUM) Q "UNKNOWN"
  1. FF I $D(^DIC(FILENUM)) D
  1. .S FILE=$P($G(^DIC(FILENUM,0)),"^",1)
  1. E I $D(^DD(FILENUM)) S FILENUM=+$G(^DD(FILENUM,0,"UP")) G FF
  1. Q FILE_" FILE"