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

VENPCC1G.m

Go to the documentation of this file. 
  1. VENPCC1G ; IHS/OIT/GIS - VERSION 2.5 EXTENSIONS ; 
  1.  ;;2.6;PCC+;;NOV 12, 2007
  1.  ;
  1.  ; 
  1.  ;
  1. VER22(DFN,PRV,VISIT,DEFEF,DEPTIEN) ;EP-EXTENSIONS FOR ANMC, GIMC AND OTHERS
  1.  N TMP
  1.  S TMP="^TMP(""VEN PRNT"",$J,1)"
  1.  I $D(^DD(200,"B","MS4 PROVIDER NUMBER")) D MS4(PRV)
  1.  I $D(^DD(200,"B","IHS ADC")) D ADC(PRV)
  1.  D EAC(VISIT)
  1.  D DEA(PRV)
  1.  D MAIL(DFN)
  1.  D PHONE(DFN)
  1.  I $P($G(^VEN(7.41,DEFEF,5)),U,13) D MH(DFN,DEFEF)
  1.  D MTYPE(DEFEF)
  1.  D APPT(DFN)
  1.  D DUR(DFN,DEPTIEN)
  1.  D CVD(DFN)
  1.  D DES(DFN)
  1.  Q
  1.  ;
  1. DES(DFN) ; EP-DESIGNATED PROVIDERS IN b14-b16
  1.  N PRV,MHP,MHM
  1.  S PRV=$P($G(^AUPNPAT(DFN,0)),U,14) I PRV="" G DES1
  1.  S PRV=$$PRV(PRV)
  1. DES1 I PRV="" S PRV="Unknown"
  1.  S @TMP@("b14")="PCP: "_PRV
  1.  S MHP=$P($G(^AUPNPAT(DFN,17)),U,1)
  1.  S MHP=$P($G(^VA(200,+MHP,0)),U)
  1.  I $L(MHP) S MHP=$P(MHP,",",2)_" "_$P(MHP,",")
  1.  I MHP="" S MHP="Unknown"
  1.  S @TMP@("b15")="MH Provider: "_MHP
  1.  S MHM=$P($G(^AUPNPAT(DFN,17)),U,4)
  1.  S MHM=$P($G(^VA(200,+MHM,0)),U)
  1.  I $L(MHM) S MHM=$P(MHM,",",2)_" "_$P(MHM,",")
  1.  I MHM="" S MHM="Unknown"
  1.  S @TMP@("b16")="MH Manager: "_MHM
  1.  Q
  1.  ; 
  1. PRV(PRV) ; EP-GIVEN A PRIMARY PROVIDER IEN RETURN THE PROVIDER NAME
  1.  N NAME,FNLN
  1.  I '$G(PRV) Q ""
  1.  I $G(^DD(9000001,.14,0))["VA(200" S NAME=$P($G(^VA(200,+PRV,0)),U) ; NEW PERSON FILE IMPLEMENTED
  1.  E  S %=U_"DIC("_16_")",NAME=$P($G(@%@(+PRV,0)),U) ; NEW PERSON FILE NOT IMPLEMENTED
  1.  I $L(NAME) S FNLN=$P(NAME,",",2)_" "_$P(NAME,",") Q FNLN
  1.  Q ""
  1.  ;
  1. MS4(PRV) ; EP-MS4 PROVIDER CODE FOR ANMC STORED IN b2
  1.  N CODE
  1.  S CODE=$$GET1^DIQ(200,(PRV_","),"MS4 PROVIDER NUMBER")
  1.  I $L(CODE) S @TMP@("b2")=CODE
  1.  Q
  1.  ;
  1. ADC(PRV) ; EP-IHS ADC STORED IN b3
  1.  N ADC
  1.  S ADC=$$GET1^DIQ(200,(PRV_","),"IHS ADC")
  1.  I $L($G(ADC)) S @TMP@("b3")=ADC
  1.  Q
  1.  ;
  1. EAC(VISIT) ; EP-EXTERNAL ACCOUNT NUMBER STORED IN b4
  1.  N EAC
  1.  S EAC=$$GET1^DIQ(9000010,(VISIT_","),1211)
  1.  I $L(EAC) S @TMP@("b4")=EAC
  1.  Q
  1.  ;
  1. DEA(PRV) ; EP-DEA NUMBER STORED IN b5
  1.  N DEA
  1.  S DEA=$$GET1^DIQ(200,(PRV_","),53.2)
  1.  I $L(DEA) S @TMP@("b5")=DEA
  1.  Q
  1.  ;
  1. MAIL(DFN) ; EP-MAILING ADDRESS STORED IN b6-b9
  1.  N STG,PCE,CNT,X
  1.  S STG=".111^.114^.115^.116"
  1.  F CNT=1:1:4 D
  1.  . S X=$$GET1^DIQ(2,(DFN_","),$P(STG,U,CNT))
  1.  . I $L(X) S @TMP@("b"_(5+CNT))=X
  1.  . Q
  1.  Q
  1.  ;
  1. PHONE(DFN) ; EP-PHONE NUMBERS STORED IN b10 AND b11
  1.  N STG,X,CNT
  1.  S CNT=1
  1.  F STG=.131,.132 D
  1.  . S X=$$GET1^DIQ(2,(DFN_","),STG)
  1.  . I $L(X) S @TMP@("b"_(9+CNT))=X
  1.  . S CNT=CNT+1
  1.  . Q
  1.  Q
  1.  ;
  1. DX(PRV,DFN,DEFEF,DEPTIEN) ; EP-GET PREFERRED DIAGNOSES
  1.  I $L($T(DX^VENPCC1P)),$O(^VEN(7.34,0)) D DX^VENPCC1P(DEFEF,PRV,DFN,DEPTIEN) Q  ; NEW DX PREF LIST ; PATCHED BY GIS/OIT 10/6/05 ; PCC+ 2.5 PATCH 1
  1.  NEW DIEN,GENERIC,ICD,IIEN,NAME,PTYPE,TOT,VAR,VAR1,X,%,INDX,SEC,CTYPE,CODE
  1.  S PTYPE=$$CLASS^VENPCC1B(DFN) I PTYPE="" S STOP=1 Q
  1.  S INDX=PRV_"."_PTYPE
  1.  S CTYPE=$P($G(^VEN(7.41,DEFEF,5)),U,12)
  1.  I '$D(^VEN(7.1,"AG",INDX)) S INDX=$$CP^VENPCCU(+$G(DEPTIEN))_"."_PTYPE
  1.  I '$D(^VEN(7.1,"AG",INDX)) S INDX=$$GP^VENPCCU_"."_PTYPE
  1.  S DIEN=0 F TOT=1:1:60 S DIEN=$O(^VEN(7.1,"AG",INDX,DIEN)) Q:'DIEN  D
  1.  . S X=$G(^VEN(7.1,DIEN,0)),ICD=$P(X,U,2),NAME=$P(X,U,3),SEC=$P(X,U,6) I '$L(NAME) Q
  1.  . S CODE=$S('CTYPE:ICD,CTYPE=1:SEC,CTYPE=2:(ICD_$S($L(SEC):"/",1:"")_SEC),1:"")
  1.  . S NAME=$TR(NAME,$C(34),""),NAME=$E(NAME,1,27)
  1.  . S VAR="d"_TOT,VAR1=VAR_"c"
  1.  . S @TMP@(1,VAR)=NAME,@TMP@(1,VAR1)=CODE
  1.  . Q
  1.  K @TMP@(0)
  1.  Q
  1.  ; 
  1. MH(DFN,DEFEF) ; EP-LAST 15 MH POVS
  1.  N PIEN,IIEN,X,NIEN,NARR,VAR,VAR1,TOT,VIEN,DATE,Y
  1.  S TOT=44,PIEN=999999999999
  1.  F  S PIEN=$O(^AUPNVPOV("AC",DFN,PIEN),-1)  Q:TOT>59  Q:'PIEN  D  ; GET POVS IN REVERSE ORDER
  1.  . S X=$G(^AUPNVPOV(PIEN,0)),NIEN=$P(X,U,4),IIEN=+X,VIEN=$P(X,U,3)
  1.  . S ICD=$P($G(^ICD9(IIEN,0)),U) I +ICD<290!(+ICD>319.999999) Q  ; FILTER OUT NON MENTAL HEALTH DXS
  1.  . S NARR=$G(^AUTNPOV(+$G(NIEN),0))
  1.  . I $P($G(^VEN(7.41,DEFEF,5)),U,14) D  ; DISPLAY DATE WITH POV
  1.  .. S Y=+$G(^AUPNVSIT(+VIEN,0)) I 'Y S DATE="<date unk>"
  1.  .. I Y X ^DD("DD") S DATE=$P(Y,"@")
  1.  .. I $L(DATE) S NARR=NARR_" ("_DATE_")"
  1.  .. Q
  1.  . I '$L(NARR) S NARR=$P($G(^ICD9(IIEN,0)),U,3) I '$L(NARR) S NARR="<missing narrative>"
  1.  . S TOT=TOT+1
  1.  . S VAR="d"_TOT,VAR1=VAR_"c"
  1.  . S @TMP@(VAR)=$E(NARR,1,$S($P($G(^VEN(7.41,DEFEF,5)),U,14):35,1:22)) ; ALLOW MORE SPACE IF DATE INCLUDED
  1.  . S @TMP@(VAR1)=ICD
  1.  . Q
  1.  S TOT=TOT+1
  1.  F %=TOT:1:60 S @TMP@(("d"_%))="",@TMP@(("d"_%_"c"))="" ; CLEAN OUT THE REST OF THE RANGE
  1.  Q
  1.  ;
  1. MTYPE(DEFEF) ; EP-MED HEADER = b12
  1.  N TYPE,A,C
  1.  S (A,C)=0
  1.  S TYPE="All Meds"
  1.  I '$G(DEFEF) G MT1
  1.  I $P($G(^VEN(7.41,DEFEF,2)),U,7) S C=1
  1.  I $P($G(^VEN(7.41,DEFEF,2)),U,8) S A=1
  1.  I A,C S TYPE="All Active Chronic Meds" G MT1
  1.  I A S TYPE="All Active Meds" G MT1
  1.  I C S TYPE="All Chronic Meds"
  1. MT1 S @TMP@("b"_12)=TYPE
  1.  Q
  1.  ; 
  1. APPT(DFN) ; EP-DISPLAY PENDING APPTS IN b41-b50
  1.  N DATE,ASTG,TIME,VDT,DSTG,AIEN,CLINIC,STG,TOT,DUR,CIEN,Y
  1.  S TOT=0 ; COUNTER FOR 'FOUND' APPOINTMENTS
  1.  S DATE=DT-.01 F  S DATE=$O(^DPT(DFN,"S",DATE)) Q:'DATE  D  I TOT>9 Q
  1.  . ; FIND ALL FUTURE DATES WHEN THIS PT HAS AN APPT
  1.  . ; QUIT WHEN YOU GET NEXT 10 PENDING APPTS FOR THIS PATIENT - ALL CLINICS
  1.  . S ASTG=^DPT(DFN,"S",DATE,0) I '$L(ASTG) Q
  1.  . I "CP"[$E($P(ASTG,U,2)_" ") Q  ; STOP LOOKING IF APPT WAS CANCELLED
  1.  . S Y=DATE\1 X ^DD("DD") S VDT=Y ; FORMAT DATE
  1.  . S TIME=$E($P(DATE,".",2)_"000",1,4) S:TIME>1300 TIME=TIME-1200 S:$L(TIME)=3 TIME=" "_TIME S:$E(TIME)="0" TIME=" "_$E(TIME,2,4) S TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) ; FORMAT TIME
  1.  . S CIEN=+ASTG,CLINIC=$P($G(^SC(CIEN,0)),U,1) I '$L(CLINIC) Q  ; GET CLINIC NAME
  1.  . S AIEN=0 F  S AIEN=$O(^SC(CIEN,"S",DATE,1,AIEN)) Q:'AIEN  I +^SC(CIEN,"S",DATE,1,AIEN,0)=DFN D  I TOT>9 Q
  1.  .. ; GET ALL APPTS FOR THIS CLINIC IN THIS CLINIC ON THE SPECIFIED DATE. STOP WHEN YOU FIND THIS PTS APPT.
  1.  .. S DUR=$P(^SC(CIEN,"S",DATE,1,AIEN,0),U,2) ; GET THE VISIT DURATION
  1.  .. I DUR S DUR=DUR_" min."
  1.  .. S STG=VDT_" "_TIME_"  "_CLINIC
  1.  .. I $L(DUR) S STG=STG_" ["_DUR_"]"
  1.  .. S TOT=TOT+1 ; INCRIMENT THE APPT COUNTER (MAX ALLOWED IS 10)
  1.  .. S @TMP@("b"_(40+TOT))=STG ; STORE RESULTS IN MAIL MERGE FIELDS b41-b50
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ; 
  1. DUR(DFN,DEPTIEN) ; EP-DISPLAY CURRENT APPOINTMENT IN b40
  1.  N DATE,ASTG,TIME,VDT,DSTG,AIEN,CLINIC,STG,DUR,CIEN,CSIEN,DSIEN,STOP,Y
  1.  S DSIEN=$P($G(^VEN(7.95,+$G(DEPTIEN),0)),U,4) I 'DSIEN Q  ; GET DEPT CLINIC STOP IEN
  1.  S DATE=DT-.01 F  S DATE=$O(^DPT(DFN,"S",DATE)) Q:'DATE  Q:DATE>(DT+.9999)  D  I $G(STOP) Q
  1.  . ; SEE IF PT HAS AT LEAST 1 APPT TODAY - OTHERWISE QUIT
  1.  . S ASTG=^DPT(DFN,"S",DATE,0) I '$L(ASTG) Q
  1.  . I "CP"[$E($P(ASTG,U,2)_" ") Q  ; STOP LOOKING IF APPT WAS CANCELLED
  1.  . S Y=DATE\1 X ^DD("DD") S VDT=Y ; FORMAT DATE
  1.  . S TIME=$E($P(DATE,".",2)_"000",1,4) S:TIME>1300 TIME=TIME-1200 S:$L(TIME)=3 TIME=" "_TIME S:$E(TIME)="0" TIME=" "_$E(TIME,2,4) S TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) ; FORMAT TIME
  1.  . S CIEN=+ASTG Q:'CIEN  S CLINIC=$P($G(^SC(CIEN,0)),U,1) I '$L(CLINIC) Q  ; GET CLINIC NAME
  1.  . S CSIEN=$P($G(^SC(CIEN,0)),U,7) I CSIEN'=DSIEN Q  ; HOSPITAL LOC STOP CODE MUST MATCH PCC+ DEPT STOP CODE
  1.  . S AIEN=0 F  S AIEN=$O(^SC(CIEN,"S",DATE,1,AIEN)) Q:'AIEN  I +^SC(CIEN,"S",DATE,1,AIEN,0)=DFN D  I $G(STOP) Q
  1.  .. ; GET ALL APPTS FOR THIS THIS CLINIC ON THE SPECIFIED DATE. STOP WHEN YOU FIND THE PTS APPT. 
  1.  .. S DUR=$P(^SC(CIEN,"S",DATE,1,AIEN,0),U,2) ; GET THE VISIT DURATION
  1.  .. I DUR S DUR=DUR_" min."
  1.  .. S STG=VDT_" "_TIME_"  "_CLINIC
  1.  .. I $L(DUR) S STG=STG_" ["_DUR_"]"
  1.  .. S STOP=1
  1.  .. S @TMP@("b40")=STG ; STORE RESULTS IN MAIL MERGE FIELD b40
  1.  .. Q
  1.  . Q
  1.  Q
  1.  ;
  1. CVD(DFN) ; EP-CVD INFO FOR ANMC IN b13
  1.  N X,DOB,SEX,AGE
  1.  S X=$G(^DPT(+$G(DFN),0)) I '$L(X) Q
  1.  S SEX=$P(X,U,2) I SEX'="F" Q
  1.  S DOB=$P(X,U,3) I 'DOB Q
  1.  S AGE=(DT-DOB)\10000
  1.  I AGE<40 Q
  1.  I AGE>60 Q
  1.  S @TMP@("b13")="CVD: __Can __Decl __Referred"
  1.  Q
  1.  ;