BDGPCCE2 ; IHS/ANMC/LJF - PULL UP ALL I VISITS ;
;;5.3;PIMS;**1005,1016**;MAY 28, 2004;Build 20
;IHS/OIT/LJF 04/14/2006 PATCH 1005 added ;EP to EN - called by BDGPCCEL
;
EN ;EP -- main entry point for BDG IC I VISITS ;IHS/OIT/LJF 04/14/2006 PATCH 1005
; Assumes DFN and BDGV are set
D MSG^BDGF("Please wait while I compile the list...",1,0)
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG IC I VISITS")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X,Y,VH
S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
;
S X=$$GET1^DIQ(2,DFN,.01)_$$SP(5)_$$HRCN^BDGF2(DFN,DUZ(2))
S VALMHDR(2)=$$SP(79-$L(X)\2)_X
;
S X="Admitted on "_$$GET1^DIQ(9000010,BDGV,.01)
S VALMHDR(3)=$$SP(79-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
K ^TMP("BDGPCCE2",$J)
S VALMCNT=0
NEW ADM,DSC,BEG,DATE,VST,COUNT,LINE
S ADM=$$GET1^DIQ(9000010,BDGV,.01,"I")\1 ;admit date
S BEG=$$FMADD^XLFDT(ADM,-3) ;72/24 rule
S DSC=$$GET1^DIQ(9000010.02,+$O(^AUPNVINP("AD",BDGV,0)),.01,"I")
I DSC="" S DSC=DT
S BEG=(9999999-BEG)_".9999999",DATE=9999999-DSC
;
F S DATE=$O(^AUPNVSIT("AA",DFN,DATE)) Q:'DATE Q:(DATE>BEG) D
. S VST=0 F S VST=$O(^AUPNVSIT("AA",DFN,DATE,VST)) Q:'VST D
.. I "HCTE"[$$GET1^DIQ(9000010,VST,.07,"I") Q
.. I $$GET1^DIQ(9000010,VST,.11)="DELETED" Q
.. I $$GET1^DIQ(9000010,VST,.06,"I")'=DUZ(2) Q ;wrong facility
.. ;
.. S COUNT=$G(COUNT)+1 ;number used to select visit for editing
.. ;S LINE=$J(COUNT,3)_". "_$$GET1^DIQ(9000010,VST,.01) ;vist date
.. ;ihs/cmi/maw 07/02/2012 PATCH 1016 added a space to visit date
.. S LINE=$J(COUNT,4)_". "_$$GET1^DIQ(9000010,VST,.01) ;vist date
.. S LINE=$$PAD(LINE,30)_$$GET1^DIQ(9000010,VST,.07,"I") ;ser categ
.. ;
.. ; find all llinks v files to this visit
.. K BDGA D VFILES(VST,.BDGA)
.. I '$D(BDGA) D Q
... D SET($$PAD(LINE,40)_"No Dependent Entries",.VALMCNT,COUNT,VST)
.. ;
.. S FIRST=1,NAME=0 F S NAME=$O(BDGA(NAME)) Q:NAME="" D
... S LINE=$$PAD(LINE,40)_$S(FIRST:"Has ",1:$$SP(4))
... S LINE=LINE_$J(BDGA(NAME),4)_" "_NAME
... D SET(LINE,.VALMCNT,COUNT,VST) S LINE=$$SP(40)
.. D SET("",.VALMCNT,COUNT,VST)
;
I '$D(^TMP("BDGPCCE2",$J)) D SET("No Visits Found",.VALMCNT,1,0)
Q
;
VFILES(V,ARRAY) ; find linked v files and counts
NEW FILE,GLOBAL,IEN,NAME
S FILE=9000010
F S FILE=$O(^DIC(FILE)) Q:'FILE Q:(FILE>9000010.9999) D
. S GLOBAL=$G(^DIC(FILE,0,"GL")) Q:GLOBAL=""
. S GLOBAL=$P(GLOBAL,"(") ;strip off parens
. S NAME=$P($P(^DIC(FILE,0),U),"V ",2)_"S"
. ;
. S IEN=0 F S IEN=$O(@GLOBAL@("AD",V,IEN)) Q:'IEN D
.. S ARRAY(NAME)=$G(ARRAY(NAME))+1
Q
;
SET(DATA,NUM,CNT,IEN) ; put display line into array
S NUM=NUM+1
S ^TMP("BDGPCCE2",$J,NUM,0)=DATA
S ^TMP("BDGPCCE2",$J,"IDX",NUM,CNT)=IEN
Q
;
EDITCAT ;EP; called by Edit Service Category protocol
NEW BDGN,DIE,DA,DR,AUPNVSIT
D GETVST I 'BDGN S VALMBCK="R" Q
S DIE="^AUPNVSIT(",DA=BDGN,DR=".07" D ^DIE
S AUPNVSIT=BDGN D MOD^AUPNVSIT
D RESET
Q
;
EDITVST ;EP; called by Edit Visit protocol
NEW APCDVSIT,APCDPAT,BDGN
D GETVST I 'BDGN S VALMBCK="R" Q
S APCDPAT=DFN,APCDVSIT=BDGN
D EN^APCDEL,^APCDEKL,RESET
Q
;
VIEWVST ;EP; called by View Visit protocol
NEW BDGN,APCDPAT,APCDVSIT
D GETVST I 'BDGN S VALMBCK="R" Q
S APCDPAT=DFN,APCDVSIT=BDGN
D ^APCDVD ;public entry point
D EN^XBVK("APCD") S VALMBCK="R"
Q
Q
;
RESET ;EP; return from protocol & rebuild list
S VALMBCK="R" D TERM^VALM0,HDR,INIT Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BDGPCCE2",$J)
Q
;
EXPND ; -- expand code
Q
;
GETVST ; select visit from list
; returns BDGN
NEW X,Y,Z
S BDGN=0 D FULL^VALM1
D EN^VALM2(XQORNOD(0),"OS")
I '$D(VALMY) Q
S X=0 F S X=$O(VALMY(X)) Q:X="" D
. S Y=0 F S Y=$O(^TMP("BDGPCCE2",$J,"IDX",Y)) Q:Y="" D
.. S Z=$O(^TMP("BDGPCCE2",$J,"IDX",Y,0))
.. Q:^TMP("BDGPCCE2",$J,"IDX",Y,Z)=""
.. I Z=X S BDGN=^TMP("BDGPCCE2",$J,"IDX",Y,Z)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGPCCE2 ; IHS/ANMC/LJF - PULL UP ALL I VISITS ;
+1 ;;5.3;PIMS;**1005,1016**;MAY 28, 2004;Build 20
+2 ;IHS/OIT/LJF 04/14/2006 PATCH 1005 added ;EP to EN - called by BDGPCCEL
+3 ;
EN ;EP -- main entry point for BDG IC I VISITS ;IHS/OIT/LJF 04/14/2006 PATCH 1005
+1 ; Assumes DFN and BDGV are set
+2 DO MSG^BDGF("Please wait while I compile the list...",1,0)
+3 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+4 DO EN^VALM("BDG IC I VISITS")
+5 DO CLEAR^VALM1
+6 QUIT
+7 ;
HDR ; -- header code
+1 NEW X,Y,VH
+2 SET VALMHDR(1)=$$SP(15)_$$CONF^BDGF
+3 ;
+4 SET X=$$GET1^DIQ(2,DFN,.01)_$$SP(5)_$$HRCN^BDGF2(DFN,DUZ(2))
+5 SET VALMHDR(2)=$$SP(79-$LENGTH(X)\2)_X
+6 ;
+7 SET X="Admitted on "_$$GET1^DIQ(9000010,BDGV,.01)
+8 SET VALMHDR(3)=$$SP(79-$LENGTH(X)\2)_X
+9 QUIT
+10 ;
INIT ; -- init variables and list array
+1 KILL ^TMP("BDGPCCE2",$JOB)
+2 SET VALMCNT=0
+3 NEW ADM,DSC,BEG,DATE,VST,COUNT,LINE
+4 ;admit date
SET ADM=$$GET1^DIQ(9000010,BDGV,.01,"I")\1
+5 ;72/24 rule
SET BEG=$$FMADD^XLFDT(ADM,-3)
+6 SET DSC=$$GET1^DIQ(9000010.02,+$ORDER(^AUPNVINP("AD",BDGV,0)),.01,"I")
+7 IF DSC=""
SET DSC=DT
+8 SET BEG=(9999999-BEG)_".9999999"
SET DATE=9999999-DSC
+9 ;
+10 FOR
SET DATE=$ORDER(^AUPNVSIT("AA",DFN,DATE))
IF 'DATE
QUIT
IF (DATE>BEG)
QUIT
Begin DoDot:1
+11 SET VST=0
FOR
SET VST=$ORDER(^AUPNVSIT("AA",DFN,DATE,VST))
IF 'VST
QUIT
Begin DoDot:2
+12 IF "HCTE"[$$GET1^DIQ(9000010,VST,.07,"I")
QUIT
+13 IF $$GET1^DIQ(9000010,VST,.11)="DELETED"
QUIT
+14 ;wrong facility
IF $$GET1^DIQ(9000010,VST,.06,"I")'=DUZ(2)
QUIT
+15 ;
+16 ;number used to select visit for editing
SET COUNT=$GET(COUNT)+1
+17 ;S LINE=$J(COUNT,3)_". "_$$GET1^DIQ(9000010,VST,.01) ;vist date
+18 ;ihs/cmi/maw 07/02/2012 PATCH 1016 added a space to visit date
+19 ;vist date
SET LINE=$JUSTIFY(COUNT,4)_". "_$$GET1^DIQ(9000010,VST,.01)
+20 ;ser categ
SET LINE=$$PAD(LINE,30)_$$GET1^DIQ(9000010,VST,.07,"I")
+21 ;
+22 ; find all llinks v files to this visit
+23 KILL BDGA
DO VFILES(VST,.BDGA)
+24 IF '$DATA(BDGA)
Begin DoDot:3
+25 DO SET($$PAD(LINE,40)_"No Dependent Entries",.VALMCNT,COUNT,VST)
End DoDot:3
QUIT
+26 ;
+27 SET FIRST=1
SET NAME=0
FOR
SET NAME=$ORDER(BDGA(NAME))
IF NAME=""
QUIT
Begin DoDot:3
+28 SET LINE=$$PAD(LINE,40)_$SELECT(FIRST:"Has ",1:$$SP(4))
+29 SET LINE=LINE_$JUSTIFY(BDGA(NAME),4)_" "_NAME
+30 DO SET(LINE,.VALMCNT,COUNT,VST)
SET LINE=$$SP(40)
End DoDot:3
+31 DO SET("",.VALMCNT,COUNT,VST)
End DoDot:2
End DoDot:1
+32 ;
+33 IF '$DATA(^TMP("BDGPCCE2",$JOB))
DO SET("No Visits Found",.VALMCNT,1,0)
+34 QUIT
+35 ;
VFILES(V,ARRAY) ; find linked v files and counts
+1 NEW FILE,GLOBAL,IEN,NAME
+2 SET FILE=9000010
+3 FOR
SET FILE=$ORDER(^DIC(FILE))
IF 'FILE
QUIT
IF (FILE>9000010.9999)
QUIT
Begin DoDot:1
+4 SET GLOBAL=$GET(^DIC(FILE,0,"GL"))
IF GLOBAL=""
QUIT
+5 ;strip off parens
SET GLOBAL=$PIECE(GLOBAL,"(")
+6 SET NAME=$PIECE($PIECE(^DIC(FILE,0),U),"V ",2)_"S"
+7 ;
+8 SET IEN=0
FOR
SET IEN=$ORDER(@GLOBAL@("AD",V,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+9 SET ARRAY(NAME)=$GET(ARRAY(NAME))+1
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
SET(DATA,NUM,CNT,IEN) ; put display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGPCCE2",$JOB,NUM,0)=DATA
+3 SET ^TMP("BDGPCCE2",$JOB,"IDX",NUM,CNT)=IEN
+4 QUIT
+5 ;
EDITCAT ;EP; called by Edit Service Category protocol
+1 NEW BDGN,DIE,DA,DR,AUPNVSIT
+2 DO GETVST
IF 'BDGN
SET VALMBCK="R"
QUIT
+3 SET DIE="^AUPNVSIT("
SET DA=BDGN
SET DR=".07"
DO ^DIE
+4 SET AUPNVSIT=BDGN
DO MOD^AUPNVSIT
+5 DO RESET
+6 QUIT
+7 ;
EDITVST ;EP; called by Edit Visit protocol
+1 NEW APCDVSIT,APCDPAT,BDGN
+2 DO GETVST
IF 'BDGN
SET VALMBCK="R"
QUIT
+3 SET APCDPAT=DFN
SET APCDVSIT=BDGN
+4 DO EN^APCDEL
DO ^APCDEKL
DO RESET
+5 QUIT
+6 ;
VIEWVST ;EP; called by View Visit protocol
+1 NEW BDGN,APCDPAT,APCDVSIT
+2 DO GETVST
IF 'BDGN
SET VALMBCK="R"
QUIT
+3 SET APCDPAT=DFN
SET APCDVSIT=BDGN
+4 ;public entry point
DO ^APCDVD
+5 DO EN^XBVK("APCD")
SET VALMBCK="R"
+6 QUIT
+7 QUIT
+8 ;
RESET ;EP; return from protocol & rebuild list
+1 SET VALMBCK="R"
DO TERM^VALM0
DO HDR
DO INIT
QUIT
+2 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("BDGPCCE2",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
GETVST ; select visit from list
+1 ; returns BDGN
+2 NEW X,Y,Z
+3 SET BDGN=0
DO FULL^VALM1
+4 DO EN^VALM2(XQORNOD(0),"OS")
+5 IF '$DATA(VALMY)
QUIT
+6 SET X=0
FOR
SET X=$ORDER(VALMY(X))
IF X=""
QUIT
Begin DoDot:1
+7 SET Y=0
FOR
SET Y=$ORDER(^TMP("BDGPCCE2",$JOB,"IDX",Y))
IF Y=""
QUIT
Begin DoDot:2
+8 SET Z=$ORDER(^TMP("BDGPCCE2",$JOB,"IDX",Y,0))
+9 IF ^TMP("BDGPCCE2",$JOB,"IDX",Y,Z)=""
QUIT
+10 IF Z=X
SET BDGN=^TMP("BDGPCCE2",$JOB,"IDX",Y,Z)
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
