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

DVBCUTIL.m

Go to the documentation of this file.
  1. DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 11/3/2010
  1. ;;2.7;AMIE;**17,126,143,149,184**;Apr 10, 1995;Build 10
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. KILL ;common exit
  1. D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
  1. K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
  1. K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
  1. K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
  1. K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
  1. K COUNTY,PROVINCE,POSTALCD,COUNTRY
  1. G KILL^DVBCUTL2
  1. ;
  1. DICW ;used on ^DIC lookups only
  1. W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1
  1. W ! Q
  1. ;
  1. DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY="" S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2
  1. Q
  1. ;
  1. DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
  1. Q
  1. ;
  1. VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2)
  1. S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown")
  1. S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10)
  1. S ZPR=$P(DTA,U,10) S PRIO="" D S:PRIO']"" PRIO="Unknown"
  1. . I ZPR="T" S PRIO="Terminal" Q
  1. . I ZPR="P" S PRIO="Prisoner of war" Q
  1. . I ZPR="OS" S PRIO="Original SC" Q
  1. . I ZPR="ON" S PRIO="Original NSC" Q
  1. . I ZPR="I" S PRIO="Increase" Q
  1. . I ZPR="R" S PRIO="Review" Q
  1. . I ZPR="OTR" S PRIO="Other" Q
  1. . I ZPR="E" S PRIO="Inadequate exam" Q
  1. . I ZPR="AO" S PRIO="Agent Orange" Q
  1. . I ZPR="BDD" S PRIO="Ben Deliv at Disch" Q
  1. . I ZPR="IDES" S PRIO="IDES" Q
  1. . I ZPR="QS" S PRIO="Quick Start"
  1. K DVBAINSF S:ZPR="E" DVBAINSF=""
  1. S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
  1. I $D(^DPT(DFN,.11)) D
  1. .S DTA=^DPT(DFN,.11)
  1. .S ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4)
  1. .S ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
  1. .S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
  1. .S COUNTY=$P(DTA,U,7),PROVINCE=$P(DTA,U,8),POSTALCD=$P(DTA,U,9)
  1. .S COUNTRY=$P(DTA,U,10)
  1. S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
  1. I $D(^DPT(DFN,.121)) D ;DVBA/126 added
  1. .S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
  1. .S DTT=^DPT(DFN,.121)
  1. .S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4)
  1. .S TZIP=$P(DTT,U,12) S:TZIP'="" TZIP=$S($L(TZIP)>5:$E(TZIP,1,5)_"-"_$E(TZIP,6,9),1:TZIP) I TZIP="" S TZIP="No Zip"
  1. .S TCITY=$S(TCITY]"":TCITY,1:"Unknown") S TST=$P(DTT,U,5) I TST]"" S TST=$S($D(^DIC(5,TST,0)):$P(^(0),U,1),1:"Unknown")
  1. .S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown"
  1. S EDTA=$$SVC(DFN,"I"),EOD=$P(EDTA,U),RAD=$P(EDTA,U,2),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
  1. Q
  1. ;
  1. HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
  1. S JII=""
  1. F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII="" S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W !
  1. Q
  1. ;
  1. ADDR ;
  1. N ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE
  1. N PRDSV,ELIG,INCMP
  1. S (ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE)=""
  1. I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),ADD3=$P(DTA,U,3),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7),PROVINCE=$P(DTA,U,8),POSTCODE=$P(DTA,U,9),COUNTRY=$P(DTA,U,10)
  1. W !!?0,"Address: ",?14,ADD1,!
  1. W:ADD2]"" ?14,ADD2,!
  1. W:ADD3]"" ?14,ADD3,!
  1. ;Functionality for USA Unique Address Output
  1. D:$$ISFORGN(COUNTRY)'>0
  1. . S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
  1. . S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
  1. . S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
  1. . W ?0,"City:",?14,CITY," ",STATE," ",ZIP,!?0,"County:",?14,CNTY,!
  1. ;Functionality for Foreign Unique Address Output
  1. D:$$ISFORGN(COUNTRY)>0
  1. . I POSTCODE="" S POSTCODE="Unknown"
  1. . I CITY="" S CITY="Unknown"
  1. . I PROVINCE="" S PROVINCE="Unknown"
  1. . W ?0,"Postal Code:",?14,POSTCODE,!?0,"City:",?14,CITY,!?0,"Province: ",?14,PROVINCE,!
  1. W:COUNTRY>0 ?0,"Country:",?14,$$GETCNTRY(+COUNTRY),!
  1. W !
  1. S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
  1. W "Period of service: ",PRDSV,!
  1. S ELIG="",INCMP=0
  1. W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
  1. I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
  1. I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
  1. I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
  1. W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
  1. Q
  1. ;
  1. SSNSHRT ; ** Set SSN in the Format '123 45 6789' **
  1. K DVBCSSNO
  1. S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
  1. Q
  1. ;
  1. SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) **
  1. D SSNSHRT
  1. S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
  1. Q
  1. ;
  1. ISFORGN(DVBIEN) ; ** Is country entry foreign? **
  1. ; Input: DVBIEN - IEN of COUNTRY CODE file
  1. ;
  1. ; Output: Return 1 when country is foreign
  1. ; Return 0 when country is not foreign
  1. ; Return -1 on error
  1. ;
  1. N DVBCNTRY
  1. N DVBERR
  1. Q:$G(DVBIEN)="" -1
  1. S DVBCNTRY=$$GET1^DIQ(779.004,DVBIEN_",",".01","","","DVBERR")
  1. Q $S($D(DVBERR):-1,DVBCNTRY="USA":0,1:1)
  1. ;
  1. GETCNTRY(DVBIEN) ; ** Get POSTAL NAME for country code **
  1. ; Input: DVBIEN - IEN of COUNTRY CODE file
  1. ;
  1. ; Output: Return POSTAL NAME field on success or
  1. ; DESCRIPTION field when POSTAL NAME = "<NULL>";
  1. ; Otherwise, return "" on failure.
  1. ;
  1. N DVBCNTRY
  1. N DVBERR
  1. N DVBIENS
  1. N DVBNAME
  1. S DVBNAME=""
  1. I $G(DVBIEN)'="" D
  1. . S DVBIENS=DVBIEN_","
  1. . D GETS^DIQ(779.004,DVBIENS,"1.3;2","E","DVBCNTRY","DVBERR")
  1. . I '$D(DVBERR) D
  1. . . S DVBNAME=$G(DVBCNTRY(779.004,DVBIENS,1.3,"E"))
  1. . . I DVBNAME="<NULL>" S DVBNAME=$$UP^XLFSTR($G(DVBCNTRY(779.004,DVBIENS,2,"E")))
  1. Q DVBNAME
  1. ;
  1. SVC(DFN,DVBCIE) ;Retrieve Last Military Service Data Info
  1. ; Using supported API SVC^VAPDT, which encapsulates the
  1. ; Military Service Episode (MSE) changes due to the
  1. ; Enrollment Military Service Data Sharing (MSDS) project
  1. ; (Patch DG*5.3*797)
  1. ; INPUT
  1. ; DFN - Patient (#2) file internal entry number (Required)
  1. ; DVBCIE - "I" to return service dates in Fileman format (Default)
  1. ; "E" to return servce dates in external format
  1. ; OUTPUT
  1. ; Returns '^' delimitted string
  1. ; 1. Last Service Entry Date
  1. ; 2. Last Service Seperation Date
  1. ; 3. Last Service Branch
  1. ; 4. Last Service Discharge Type
  1. ;
  1. ;Quit if DFN not greater than zero
  1. Q:($G(DFN)'>0) ""
  1. ;If DVBCIE not "I" or "E" set to default of "I"
  1. S:"^I^E^"'[(U_$G(DVBCIE)_U) DVBCIE="I"
  1. N VASV,VAHOW,VAROOT,DVBMSE
  1. D SVC^VADPT
  1. D:DVBCIE="E" ;external Last MSE data
  1. . S DVBMSE=$P($G(VASV(6,4)),U,2)_"^"_$P($G(VASV(6,5)),U,2)_"^"
  1. . S DVBMSE=DVBMSE_$P($G(VASV(6,1)),U,2)_"^"_$P($G(VASV(6,3)),U,2)
  1. D:DVBCIE="I" ;internal Last MSE data
  1. . S DVBMSE=$P($G(VASV(6,4)),U)_"^"_$P($G(VASV(6,5)),U)_"^"
  1. . S DVBMSE=DVBMSE_$P($G(VASV(6,1)),U)_"^"_$P($G(VASV(6,3)),U)
  1. Q DVBMSE