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

VENPCC1F.m

Go to the documentation of this file. 
  1. VENPCC1F ; IHS/OIT/GIS - SURGICAL, PERSONAL FAMILY HISTORY ; 
  1.  ;;2.6;PCC+;;NOV 12, 2007
  1.  ;
  1.  ; ALSO CONTAINS CODE FOR PODIATRY
  1.  ; 
  1. HX(DFN,DEFEF) ; EP - GET HX INFO FOR THIS PATIENT
  1.  I $D(^DPT(+$G(DFN),0)),$D(^VEN(7.41,+$G(DEFEF),0))
  1.  E  Q
  1.  X "I $P($G(^VEN(7.41,DEFEF,5)),U,18),$L($T(SURG^VENPCC1K)) D SURG^VENPCC1K(DFN,DEFEF)" ; SURG HX
  1.  N CNT,PIEN,VPIEN,IDT,FMDT,HDT,PRVIEN,DX,DXIEN,PROC,PRV,STG,X,Y,%,PN,PNIEN,FIEN,ICD,HIEN,FMODT,ODT,MAX,T,TMP
  1.  S TMP=$NA(^TMP("VEN PRNT",$J,1))
  1. HOS I '$P($G(^VEN(7.41,DEFEF,5)),U,4) G FH  ; HX OF SURGERY
  1.  S CNT=0,IDT=0,MAX=5
  1.  I $P($G(^VEN(7.41,DEFEF,5)),U,11) S MAX=1 ; LIMIT MAX NO TO 1 - LAST ONE ONLY
  1.  F  S IDT=$O(^AUPNVPRC("AA",DFN,IDT)) Q:'IDT  S VPIEN=999999999 F  S VPIEN=$O(^AUPNVPRC("AA",DFN,IDT,VPIEN),-1) Q:'VPIEN  D  I CNT=MAX G H1
  1.  . S X=$G(^AUPNVPRC(VPIEN,0)) I '$L(X) Q
  1.  . S PIEN=+X I 'PIEN Q
  1.  . S ICD=+$P($G(^ICD0(PIEN,0)),U) I 'ICD Q  ; ICD CODE
  1.  . I $P($G(^VEN(7.41,DEFEF,5)),U,7) K T D  I $G(T) Q  ; EXCLUDE MINOR PROCEDURES
  1.  .. I ICD>85 S T=1 Q
  1.  .. I ICD=69.7 S T=1 Q
  1.  .. I ICD\1=24 S T=1 Q
  1.  .. I ICD=38.99 S T=1 Q
  1.  .. I ICD\1=23 S T=1
  1.  .. Q
  1.  . S PROC=$P($G(^ICD0(PIEN,1)),U) I '$L(PROC) Q  ; PROCEDURE NAME
  1.  . S FMDT=$P(X,U,6) I 'FMDT Q
  1.  . S HDT=$$FMTE^XLFDT(FMDT,"2D") ; PROCEDURE DATE IN M/D/Y FORMAT
  1.  . I $P($G(^VEN(7.41,DEFEF,5)),U,5) D  ; DIAGNOSIS
  1.  .. K DX
  1.  .. S DXIEN=$P(X,U,5) I 'DXIEN Q
  1.  .. S DX=$P($G(^ICD9(DXIEN,0)),U,3)
  1.  .. Q
  1.  . I $P($G(^VEN(7.41,DEFEF,5)),U,6) D  ; PROVIDER NAME
  1.  .. K PRV
  1.  .. S PRVIEN=$P(X,U,11) I 'PRVIEN Q
  1.  .. S %=U_"DIC("_16_")",PRV=$E($S($P($G(^AUTTSITE(1,0)),U,22):$P($G(^VA(200,PRVIEN,0)),U),1:$P($G(@%@(PRVIEN,0)),U)),1,15) ; PATCHED BY GIS 3/17/04
  1.  .. Q
  1.  . S Y=PROC_" ("_ICD_") "_HDT
  1.  . I $L($G(PRV)) S Y=Y_" By: "_PRV
  1.  . I $L($G(DX)) S Y=Y_" Dx: "_DX
  1.  . I $L(Y) S CNT=CNT+1,STG(CNT)=Y
  1.  . Q
  1. H1 ; OUTPUT HX SURG
  1.  F CNT=1:1:MAX S X=$G(STG(CNT)) I $L(X) S @TMP@("v"_CNT)=X
  1.  ; 
  1. FH I '$P($G(^VEN(7.41,DEFEF,5)),U,8) G PH  ; FAMILY HISTORY
  1.  S CNT=0
  1.  S FIEN=999999999 F  S FIEN=$O(^AUPNFH("AC",DFN,FIEN),-1) Q:'FIEN  D  I CNT=5 G PH
  1.  . S X=$G(^AUPNFH(FIEN,0)) I '$L(X) Q
  1.  . S DXIEN=+X I 'DXIEN Q
  1.  . S ICD=$P($G(^ICD9(DXIEN,0)),U) I '$L(ICD) Q
  1.  . S FMDT=$P(X,U,3) I 'FMDT Q
  1.  . S HDT=$$FMTE^XLFDT(FMDT,"2D")
  1.  . S PNIEN=$P(X,U,4) I 'PNIEN Q
  1.  . S PN=$P($G(^AUTNPOV(PNIEN,0)),U) I '$L(PN) Q
  1.  . S CNT=CNT+1,@TMP@("v"_(5+CNT))=PN_" ("_ICD_") "_HDT
  1.  . Q
  1.  Q
  1.  ; 
  1. PH I '$P($G(^VEN(7.41,DEFEF,5)),U,9) G PODHX  ; EP-PERSONAL HISTORY
  1.  N TMP
  1.  S TMP=$NA(^TMP("VEN PRNT",$J,1))
  1.  S CNT=0
  1.  S HIEN=999999999 F  S HIEN=$O(^AUPNPH("AC",DFN,HIEN),-1) Q:'HIEN  D  I CNT=5 G PODHX ; PATCHED BY GIS 3/19/04
  1.  . S X=$G(^AUPNPH(HIEN,0)) I '$L(X) Q
  1.  . S DXIEN=+X I 'DXIEN Q
  1.  . S ICD=$P($G(^ICD9(DXIEN,0)),U) I '$L(ICD) Q
  1.  . S FMDT=$P(X,U,3) I 'FMDT Q
  1.  . S HDT=$$FMTE^XLFDT(FMDT,"2D")
  1.  . S PNIEN=$P(X,U,4) I 'PNIEN Q
  1.  . S PN=$P($G(^AUTNPOV(PNIEN,0)),U) I '$L(PN) Q
  1.  . S CNT=CNT+1,Y=PN_" ("_ICD_") "_HDT
  1.  . I '$P($G(^VEN(7.41,DEFEF,5)),U,10) S FMODT=$P(X,U,5) I FMODT S ODT=$$FMTE^XLFDT(FMODT,"2D")  I $L(ODT) S Y=Y_" Onset: "_ODT
  1.  . S @TMP@("v"_(10+CNT))=Y
  1.  . Q
  1.  Q
  1.  ; 
  1. PODHX I '$P($G(^VEN(7.41,DEFEF,5)),U,16) Q  ; EP-PODIATRY HISTORY
  1.  I '$L($T(^APCHSPOD)) Q  ; PODIATRY HS MUST EXIST OR NOT AN OFFICIAL INSTALL
  1.  N TMP,LN,LS,CNT,X,Y,Z,%,STG,VSTG,TXT,T,NSTG
  1.  N CODE,RES,LG,GIEN,GSTG,SIDE,ASTG,AIEN,INC,SSTG,SN
  1.  S TMP="^TMP(""VEN PRNT"","_$J_",1)",T="~"
  1.  S STG=$G(^AUPNPOD(+$G(DFN),0)) I '$L(STG) Q
  1. VASC S Y=$P(STG,U,2) I Y D
  1.  . X ^DD("DD") S @TMP@("c50")=Y ; c50 DATE LAST VASC EXAM
  1.  . S VSTG=$G(^AUPNPOD(DFN,1))
  1.  . S Y=$P(VSTG,U,1),Z=$P(VSTG,U,2)
  1.  . I Y D  ; GET PULSE INFO
  1.  .. X ^DD("DD") S @TMP@("c51")=Y ; c51 DATE LAST PULSE CHECK
  1.  .. S %=$P(Z,T,1) I $L(%) S @TMP@("c52")=%
  1.  .. S %=$P(Z,T,2) I $L(%) S @TMP@("c53")=%
  1.  .. S %=$P(Z,T,3) I $L(%) S @TMP@("c54")=%
  1.  .. S %=$P(Z,T,4) I $L(%) S @TMP@("c55")=%
  1.  .. Q
  1.  . S Y=$P(VSTG,U,3),Z=$P(VSTG,U,4)
  1.  . I Y D  ; GET DOPPLER INFO
  1.  .. X ^DD("DD") S @TMP@("c56")=Y ; c56 DATE LAST DOPPLER EXAM
  1.  .. S %=$P(Z,T,1) I $L(%) S @TMP@("c57")=%
  1.  .. S %=$P(Z,T,2) I $L(%) S @TMP@("c58")=%
  1.  .. S %=$P(Z,T,3) I $L(%) S @TMP@("c59")=%
  1.  .. S %=$P(Z,T,4) I $L(%) S @TMP@("c60")=%
  1.  .. S %=$P(Z,T,5) I $L(%) S @TMP@("c48")=%
  1.  .. S %=$P(Z,T,6) I $L(%) S @TMP@("c49")=%
  1.  .. Q
  1.  . S Y=$P(VSTG,U,5),Z=$P(VSTG,U,6)
  1.  . I Y D  ; GET OSCILLOMETRY INFO
  1.  .. X ^DD("DD") S @TMP@("c61")=Y ; c61 DATE LAST OSCILLOMETRY EXAM
  1.  .. S %=$P(Z,T,1) I $L(%) S @TMP@("c62")=%
  1.  .. S %=$P(Z,T,2) I $L(%) S @TMP@("c63")=%
  1.  .. S %=$P(Z,T,3) I $L(%) S @TMP@("c64")=%
  1.  .. S %=$P(Z,T,4) I $L(%) S @TMP@("c65")=%
  1.  .. S TXT=$P(Z,T,5) I $L(TXT) D
  1.  ... S %=$P(Z,T,6) I $L(%) S @TMP@("c66")=(TXT_"="_%)
  1.  ... S %=$P(Z,T,7) I $L(%) S @TMP@("c67")=(TXT_"="_%)
  1.  ... Q
  1.  .. Q
  1.  . Q
  1. NEURO S Y=$P(STG,U,3) I Y D  ; EP-NEURO EXAM
  1.  . X ^DD("DD") S LN=Y
  1.  . S NSTG=$G(^AUPNPOD(DFN,2))
  1.  . S RES=$P(NSTG,U,1) I RES D
  1.  .. I RES=1 S @TMP@("c40")="X"
  1.  .. I RES=2 S @TMP@("c41")="X"
  1.  .. I RES=3 S @TMP@("c42")="X"
  1.  . S @TMP@("c68")=LN ; c68  LAST NEURO EXAM
  1.  . S @TMP@("c47")=$P(NSTG,U,2)
  1.  . Q
  1. GRAFT I $D(^AUPNPOD(DFN,3)) D  ; EP-GRAFTS
  1.  . S GIEN=999999
  1.  . F CNT=69:1:72 S GIEN=$O(^AUPNPOD(DFN,3,GIEN),-1) Q:'GIEN  D
  1.  .. S GSTG=$G(^AUPNPOD(DFN,3,GIEN,0)) I '$L(GSTG) Q
  1.  .. S Y=+GSTG I 'Y Q
  1.  .. X ^DD("DD") S LG=Y
  1.  .. S LG=LG_" "_$P(GSTG,U,2)
  1.  .. S @TMP@("c"_CNT)=LG ; c69-c72 GRAFTS
  1.  .. Q
  1.  . Q
  1. AMP I $D(^AUPNPOD(DFN,4)) D  ; EP-AMPUTATIONS
  1.  . S AIEN=0
  1.  . F  S AIEN=$O(^AUPNPOD(DFN,4,AIEN)) Q:'AIEN  D
  1.  .. S ASTG=$G(^AUPNPOD(DFN,4,AIEN,0)) I '$L(ASTG) Q
  1.  .. S TYPE=+ASTG,SIDE=$P(ASTG,U,2),TXT=$P(ASTG,U,3)
  1.  .. I 'TYPE Q
  1.  .. I SIDE="" Q
  1.  .. I TXT="" Q
  1.  .. S INC=(SIDE="R")
  1.  .. S CNT=(TYPE*2)+INC+71
  1.  .. S @TMP@("c"_CNT)=TXT ; c73-c98  AMPUTATIONS
  1.  .. Q
  1.  . Q
  1. SHOE S Y=$P(STG,U,4) I Y D  ; EP-SHOE FITTING
  1.  . X ^DD("DD") S SN=Y
  1.  . S SSTG=$G(^AUPNPOD(DFN,5))
  1.  . S RES=$P(SSTG,U,1) I RES D
  1.  .. I RES=1 S @TMP@("c43")="X"
  1.  .. I RES=2 S @TMP@("c44")="X"
  1.  .. I RES=3 S @TMP@("c45")="X"
  1.  .. I RES=4 S @TMP@("c46")=$P(SSTG,U,2),@TMP@("c99")="X"
  1.  .. Q
  1.  . S @TMP@("c100")=SN ; c100  LAST SHOE FITTING
  1.  . Q
  1.  Q
  1.  ;