- PXQFV ;ISL/ARS,JVS - DEPENDENT ENTRY COUNT-VISITS(AUPNVSIT) ;5/1/97 08:30
- ;;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.
- ; 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
- ...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
- PXQFV ;ISL/ARS,JVS - DEPENDENT ENTRY COUNT-VISITS(AUPNVSIT) ;5/1/97 08:30
- +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 ; 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 SET SOURCE=$PIECE(^PX(839.7,$PIECE(J,"-",1),0),"^",1)
- +10 SET ACTION=$PIECE($PIECE(J,"-",2)," ",1)
- SET ACTION=$SELECT(ACTION="E":"EDIT",ACTION="A":"CREATED",1:"")
- +11 SET PERSON=$PIECE(^VA(200,$PIECE(J," ",2),0),"^",1)
- +12 WRITE $$RE^PXQUTL(""""_ACTION_""",?16,"""_SOURCE_""",?45,"""_PERSON_"""")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 WRITE $$RE^PXQUTL("___________________________________________________________")
- +14 QUIT ""
- +15 ;----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
