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

BDGPCCEL.m

Go to the documentation of this file.
  1. BDGPCCEL ; IHS/ANMC/LJF - CODE PCC VISIT LISTING ; [ 08/12/2002 10:14 AM ]
  1. ;;5.3;PIMS;**1005,1006,1010**;MAY 28, 2004
  1. ;IHS/OIT/LJF 03/16/2006 PATCH 1005 added HF & PED mnemonic choices
  1. ; drops into ADD mode if nothing to MODIFY
  1. ; 04/06/2006 patch 1005 added trigger to stuff date coded in NICE
  1. ; prevent ^DGPMEX from asking patient name again
  1. ; 07/07/2006 PATCH 1006 prevent error if no mnemonic is selected
  1. ;cmi/anch/maw 10/20/2008 PATCH 1010 changed date exported field from .14 to 1106
  1. ;
  1. EN ; -- main entry point for BDG IC CODE
  1. ; Assumes DFN and BDGV are set
  1. NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1. D EN^VALM("BDG IC CODE")
  1. D CLEAR^VALM1
  1. Q
  1. ;
  1. HDR ; -- header code
  1. NEW X,Y,VH
  1. S VALMHDR(1)=$$SP(15)_$$CONF^BDGF
  1. ;
  1. S X=$$GET1^DIQ(2,DFN,.01)_$$SP(5)_"#"_$$HRCN^BDGF2(DFN,DUZ(2))
  1. S VALMHDR(2)=$$SP(79-$L(X)\2)_X
  1. ;
  1. S VH=$O(^AUPNVINP("AD",BDGV,0)) Q:'VH
  1. S X=$$GET1^DIQ(9000010.02,VH,.15)
  1. S Y="Coding Complete? "_$S(X="NO":"NO",1:"YES")
  1. ;S VALMHDR(3)=$$PAD(Y,30)_"Exported on "_$$GET1^DIQ(9000010,BDGV,.14) ;cmi/maw 10/10/2008 PATCH 1010 orig line
  1. S VALMHDR(3)=$$PAD(Y,30)_"Exported on "_$$GET1^DIQ(9000010,BDGV,1106) ;cmi/maw 10/10/2008 PATCH 1010 new export date
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. K ^TMP("BDGPCCE",$J)
  1. S VALMCNT=0
  1. D MSG^BDGF("Please wait while I gather all visit data...",2,0)
  1. D ^BDGPCCE1 ;build display screens
  1. Q
  1. ;
  1. ADMIT ;EP; called by Admission Data protocol
  1. D FULL^VALM1
  1. ;
  1. I '$O(^DGPM("AVISIT",BDGV,0)) D Q
  1. . D MSG^BDGF("Visit NOT linked to ADT Admission",2,0)
  1. . D MSG^BDGF("Cannot continue. Please advise your supervisor.",1,0)
  1. . D PAUSE^BDGF
  1. ;
  1. NEW BDGVH
  1. S BDGVH=$O(^AUPNVINP("AD",BDGV,0)) I 'BDGVH D Q
  1. . D MSG^BDGF("No V Hospitalization linked with Visit!!!",2,0)
  1. . D MSG^BDGF("Cannot continue. Please advise your supervisor.",1,0)
  1. . D PAUSE^BDGF
  1. ;
  1. ; add/edit # of consults and admitting dx
  1. L +^AUPNVINP(BDGVH):3 I '$T D Q
  1. . D MSG^BDGF("Someone else is updating this hospitalization.",2,0)
  1. . D MSG^BDGF("Please try again later.",1,0),PAUSE^BDGF
  1. K DIE,DA,DR S DIE="^AUPNVINP(",DA=BDGVH,DR=".08;.12" D ^DIE,EDIT
  1. L -^AUPNVINP(BDGVH)
  1. ;
  1. ; add/edit DRG
  1. L +^AUPNVSIT(BDGV):3 I '$T D Q
  1. . D MSG^BDGF("Someone else is updating this visit.",2,0)
  1. . D MSG^BDGF("Please try again later.",1,0),PAUSE^BDGF
  1. K DIE,DA,DR S DIE="^AUPNVSIT(",DA=BDGV,DR=".34" D ^DIE,EDIT
  1. L -^AUPNVSIT(BDGV)
  1. ;
  1. ; call ADT to edit common fields
  1. NEW DGPMCA,DGPMEX,DGPMAN,BDGDFN
  1. S DGPMCA=$O(^DGPM("AVISIT",BDGV,0)),DGPMEX=""
  1. S DGPMAN=$G(^DGPM(+DGPMCA,0)),BDGDFN=DFN
  1. S ^DISV(DUZ,"DGPMEX",DFN)=DGPMCA
  1. ;
  1. ;IHS/OIT/LJF 04/06/2006 PATCH 1005 set BDGCODE to prevent asking patient name again
  1. NEW BDGCODE S BDGCODE=1
  1. ;
  1. D ENEX^DGPMV20,ASK^DGPMEX,EDIT ;call extended bed control
  1. S (DFN,AUPNPAT)=BDGDFN D SETPT^BDGF(DFN) ;reset patient variables
  1. ;
  1. D RESET
  1. Q
  1. ;
  1. ADD ;EP; called by Add/Modify PCC Data protocol
  1. NEW APCDCAT,APCDVSIT,APCDPAT,APCDLOC,APCDTYPE,APCDMODE,APCDPARM
  1. NEW APCDMNE,BDGMN,BDGA,Y,APCDVLDT,APCDVLK,BDGBL,DIC
  1. S APCDCAT="H",(APCDVSIT,APCDVLK)=BDGV,APCDPAT=DFN
  1. S APCDPARM=$G(^APCDSITE(DUZ(2),0))
  1. S (APCDDATE,APCDVLDT)=$$GET1^DIQ(9000010,BDGV,.01,"I")
  1. S APCDLOC=DUZ(2),APCDTYPE=$$GET1^DIQ(9000010,BDGV,.03,"I")
  1. ;
  1. D FULL^VALM1,^APCDEIN
  1. ASK ;
  1. ;IHS/OIT/LJF 03/16/2006 PATCH 1005 rewrote subrtn to handle HF and PED
  1. K BDGA,APCDMNE W !!
  1. S BDGA(1)=" (1) DIAGNOSIS (5) IMMUNIZATIONS"
  1. S BDGA(2)=" (2) PROCEDURES (6) HEALTH FACTORS"
  1. S BDGA(3)=" (3) PROVIDERS (7) PATIENT EDUCATION"
  1. S BDGA(4)=" (4) ADMITTING DX (8) OTHER MNEMONICS"
  1. S BDGMN=$$READ^BDGF("NO^1:8","Select One","","","",.BDGA)
  1. I 'BDGMN D ENDADD Q
  1. ;
  1. ;IHS/OIT/LJF 07/07/2006 PATCH 1006 rewrote section
  1. ;I BDGMN=8 D Q
  1. I BDGMN=8 D D ASK Q
  1. . ;S Y=$$READ^BDGF("P^9001001:EMQZ","MNEMONIC")
  1. . S Y=$$READ^BDGF("P^9001001:EMQZ","MNEMONIC") Q:Y<1
  1. . S APCDMNE=+Y,APCDMNE("NAME")=$P(Y,U,2)
  1. . S APCDMODE=$$READ^BDGF("SO^A:ADD;M:MODIFY","Select MODE")
  1. . ;D ^APCDEA3,ASK
  1. . D ^APCDEA3
  1. ;
  1. E S DIC=9001001,DIC(0)="",X=$P($T(MNE+BDGMN),";;",2) D ^DIC
  1. I Y<1 D ASK Q
  1. S APCDMNE=+Y,APCDMNE("NAME")=$P(Y,U,2)
  1. S BDGBL=$P($T(MNE+BDGMN),";;",3) I (BDGMN'=8),(BDGBL="") S APCDMODE="M"
  1. E D
  1. . S Y=BDGBL_"(""AD"","_BDGV_",0)" I '$O(@Y) S APCDMODE="A" Q
  1. . S APCDMODE=$$READ^BDGF("SO^A:ADD;M:MODIFY","Select MODE")
  1. I (APCDMODE="")!(APCDMODE=U)
  1. ;
  1. D ^APCDEA3,ASK Q
  1. ;
  1. ; when done with coding, mark visit as edited and return to display
  1. ENDADD D EDIT,RESET
  1. Q
  1. ;
  1. LIST ;EP; Called by List I Visits protocol
  1. D EN^BDGPCCE2 S VALMBCK="R" Q
  1. ;
  1. PROB ;EP; Called by Problem List Update protocol
  1. NEW VALMCNT
  1. D EN1^APCDPL ;public entry point, assumes DFN is set
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. ALL ;EP; Called by Display All Data protocol (BDG IC PCC DISPLAY ALL)
  1. ; Also called by BDG VIEW PCC protocol
  1. NEW APCDPAT,APCDVSIT
  1. S APCDPAT=DFN,APCDVSIT=BDGV
  1. D ^APCDVD ;public entry point
  1. D EN^XBVK("APCD") S VALMBCK="R"
  1. Q
  1. ;
  1. FASH ;EP; Called by Final A Sheet protocol
  1. NEW DGPMCA,BDGFIN
  1. D FULL^VALM1
  1. S DGPMCA=$O(^DGPM("AVISIT",BDGV,0))
  1. S BDGFIN=$$READ^BDGF("SO^1:A Sheet Only;2:A Sheet with CPT List;3:Medicare/Medicaid A Sheet","Select Report to Print",$$GET1^DIQ(9009020.1,$$DIV^BSDU,.07,"I"),"^D FINHLP^BDGCRB")
  1. I 'BDGFIN S VALMBCK="R" Q
  1. D PAT^BDGCRB(DFN,DGPMCA,BDGFIN,1,2)
  1. D PAUSE^BDGF S VALMBCK="R"
  1. Q
  1. ;
  1. RESET ;EP; return from protocol & rebuild list
  1. S VALMBCK="R" D TERM^VALM0,HDR,INIT Q
  1. ;
  1. EDIT ; update date last edited
  1. NEW AUPNVSIT S AUPNVSIT=BDGV D MOD^AUPNVSIT Q
  1. ;
  1. CHECK(DATE) ;EP; run inpatient edit check
  1. ; DATE=1 if check to be run only if updated today
  1. ; DATE=0 run check anyway
  1. I DATE,$$GET1^DIQ(9000010,BDGV,.13,"I")'=DT Q
  1. ;
  1. NEW BDGVH,X,Y
  1. S BDGVH=$O(^AUPNVINP("AD",BDGV,0)) Q:'BDGVH
  1. D FULL^VALM1
  1. S X=$$GET1^DIQ(9000010.02,BDGVH,.15)
  1. S Y="Coding Complete? "_$S(X="NO":"NO",1:"YES")
  1. ;S X=$$GET1^DIQ(9000010,BDGV,.14) ;cmi/maw 10/20/2008 PATCH 1010 orig line
  1. ;I X]"" S Y=$$PAD(Y,30)_"Exported on "_$$GET1^DIQ(9000010,BDGV,.14) ;cmi/maw 10/20/2008 PATCH 1010 orig line
  1. S X=$$GET1^DIQ(9000010,BDGV,1106) ;cmi/maw 10/20/2008 PATCH 1010 new export date
  1. I X]"" S Y=$$PAD(Y,30)_"Exported on "_$$GET1^DIQ(9000010,BDGV,1106) ;cmi/maw 10/20/2008 PATCH 1010 new export date
  1. D MSG^BDGF(Y,2,0)
  1. ;
  1. NEW APCDPARM,APCDVSIT,APCDLVST,APCDDATE,APCDTYPE
  1. S APCDPARM=$G(^APCDSITE(DUZ(2),0))
  1. S APCDVSIT=BDGV,APCDLVST=BDGV,APCDPAT=DFN
  1. S (APCDVLDT,APCDDATE)=$$GET1^DIQ(9000010,BDGV,.01,"I")
  1. S APCDTYPE=$$GET1^DIQ(9000010,BDGV,.03,"I")
  1. D ^APCDVCHK,PAUSE^BDGF
  1. S VALMBCK="R"
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. D CHECK(1)
  1. ;
  1. ;IHS/OIT/LJF 04/06/2006 PATCH 1005 trigger date coded in NICE if coding complete
  1. NEW ICN,VH
  1. S ICN=$O(^BDGIC("AV",BDGV,0)) ;find IC entry based on visit
  1. S VH=$O(^AUPNVINP("AD",BDGV,0)) ;find v hosp entry
  1. I ICN,VH,$$GET1^DIQ(9000010.02,VH,.15)="",$$GET1^DIQ(9009016.1,ICN,.13)="" D
  1. . S DIE="^BDGIC(",DA=ICN,DR=".13///"_DT D ^DIE ;stuff date coded
  1. . I $$GET1^DIQ(9009016.1,ICN,.22)="" S DR=".22///`"_DUZ D ^DIE ;stuff who coded chart
  1. ;end of PATCH 1005 code
  1. ;
  1. K ^TMP("BDGPCCE",$J) K BDGV,DFN D KILL^AUPNPAT
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1. ; -- D=data L=length
  1. Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1. ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1. Q $$PAD(" ",N)
  1. ;
  1. ;IHS/OIT/LJF 03/16/2006 PATCH 1005 added HF & PED & global refs
  1. MNE ;;
  1. ;;PV;;^AUPNVPOV;;
  1. ;;OP;;^AUPNVPRC;;
  1. ;;PRV;;^AUPNVPRV;;
  1. ;;ADX;;
  1. ;;IM;;^AUPNVIMM;;
  1. ;;HF;;^AUPNVHF;;
  1. ;;PED;;^AUPNVPED;;