- DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 11/3/2010
- ;;2.7;AMIE;**17,126,143,149,184**;Apr 10, 1995;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- KILL ;common exit
- D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
- 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
- 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
- K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
- K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
- K COUNTY,PROVINCE,POSTALCD,COUNTRY
- G KILL^DVBCUTL2
- ;
- DICW ;used on ^DIC lookups only
- 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
- W ! Q
- ;
- 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
- Q
- ;
- DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
- Q
- ;
- 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)
- 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")
- 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)
- S ZPR=$P(DTA,U,10) S PRIO="" D S:PRIO']"" PRIO="Unknown"
- . I ZPR="T" S PRIO="Terminal" Q
- . I ZPR="P" S PRIO="Prisoner of war" Q
- . I ZPR="OS" S PRIO="Original SC" Q
- . I ZPR="ON" S PRIO="Original NSC" Q
- . I ZPR="I" S PRIO="Increase" Q
- . I ZPR="R" S PRIO="Review" Q
- . I ZPR="OTR" S PRIO="Other" Q
- . I ZPR="E" S PRIO="Inadequate exam" Q
- . I ZPR="AO" S PRIO="Agent Orange" Q
- . I ZPR="BDD" S PRIO="Ben Deliv at Disch" Q
- . I ZPR="IDES" S PRIO="IDES" Q
- . I ZPR="QS" S PRIO="Quick Start"
- K DVBAINSF S:ZPR="E" DVBAINSF=""
- S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
- I $D(^DPT(DFN,.11)) D
- .S DTA=^DPT(DFN,.11)
- .S ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4)
- .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"
- .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")
- .S COUNTY=$P(DTA,U,7),PROVINCE=$P(DTA,U,8),POSTALCD=$P(DTA,U,9)
- .S COUNTRY=$P(DTA,U,10)
- S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
- I $D(^DPT(DFN,.121)) D ;DVBA/126 added
- .S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
- .S DTT=^DPT(DFN,.121)
- .S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4)
- .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"
- .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")
- .S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown"
- 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
- Q
- ;
- HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
- S JII=""
- 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 !
- Q
- ;
- ADDR ;
- N ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE
- N PRDSV,ELIG,INCMP
- S (ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE)=""
- 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)
- W !!?0,"Address: ",?14,ADD1,!
- W:ADD2]"" ?14,ADD2,!
- W:ADD3]"" ?14,ADD3,!
- ;Functionality for USA Unique Address Output
- D:$$ISFORGN(COUNTRY)'>0
- . S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
- . S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
- . S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
- . W ?0,"City:",?14,CITY," ",STATE," ",ZIP,!?0,"County:",?14,CNTY,!
- ;Functionality for Foreign Unique Address Output
- D:$$ISFORGN(COUNTRY)>0
- . I POSTCODE="" S POSTCODE="Unknown"
- . I CITY="" S CITY="Unknown"
- . I PROVINCE="" S PROVINCE="Unknown"
- . W ?0,"Postal Code:",?14,POSTCODE,!?0,"City:",?14,CITY,!?0,"Province: ",?14,PROVINCE,!
- W:COUNTRY>0 ?0,"Country:",?14,$$GETCNTRY(+COUNTRY),!
- W !
- S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
- W "Period of service: ",PRDSV,!
- S ELIG="",INCMP=0
- 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:"")
- 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")_")"
- I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
- I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
- W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
- Q
- ;
- SSNSHRT ; ** Set SSN in the Format '123 45 6789' **
- K DVBCSSNO
- S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
- Q
- ;
- SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) **
- D SSNSHRT
- S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
- Q
- ;
- ISFORGN(DVBIEN) ; ** Is country entry foreign? **
- ; Input: DVBIEN - IEN of COUNTRY CODE file
- ;
- ; Output: Return 1 when country is foreign
- ; Return 0 when country is not foreign
- ; Return -1 on error
- ;
- N DVBCNTRY
- N DVBERR
- Q:$G(DVBIEN)="" -1
- S DVBCNTRY=$$GET1^DIQ(779.004,DVBIEN_",",".01","","","DVBERR")
- Q $S($D(DVBERR):-1,DVBCNTRY="USA":0,1:1)
- ;
- GETCNTRY(DVBIEN) ; ** Get POSTAL NAME for country code **
- ; Input: DVBIEN - IEN of COUNTRY CODE file
- ;
- ; Output: Return POSTAL NAME field on success or
- ; DESCRIPTION field when POSTAL NAME = "<NULL>";
- ; Otherwise, return "" on failure.
- ;
- N DVBCNTRY
- N DVBERR
- N DVBIENS
- N DVBNAME
- S DVBNAME=""
- I $G(DVBIEN)'="" D
- . S DVBIENS=DVBIEN_","
- . D GETS^DIQ(779.004,DVBIENS,"1.3;2","E","DVBCNTRY","DVBERR")
- . I '$D(DVBERR) D
- . . S DVBNAME=$G(DVBCNTRY(779.004,DVBIENS,1.3,"E"))
- . . I DVBNAME="<NULL>" S DVBNAME=$$UP^XLFSTR($G(DVBCNTRY(779.004,DVBIENS,2,"E")))
- Q DVBNAME
- ;
- SVC(DFN,DVBCIE) ;Retrieve Last Military Service Data Info
- ; Using supported API SVC^VAPDT, which encapsulates the
- ; Military Service Episode (MSE) changes due to the
- ; Enrollment Military Service Data Sharing (MSDS) project
- ; (Patch DG*5.3*797)
- ; INPUT
- ; DFN - Patient (#2) file internal entry number (Required)
- ; DVBCIE - "I" to return service dates in Fileman format (Default)
- ; "E" to return servce dates in external format
- ; OUTPUT
- ; Returns '^' delimitted string
- ; 1. Last Service Entry Date
- ; 2. Last Service Seperation Date
- ; 3. Last Service Branch
- ; 4. Last Service Discharge Type
- ;
- ;Quit if DFN not greater than zero
- Q:($G(DFN)'>0) ""
- ;If DVBCIE not "I" or "E" set to default of "I"
- S:"^I^E^"'[(U_$G(DVBCIE)_U) DVBCIE="I"
- N VASV,VAHOW,VAROOT,DVBMSE
- D SVC^VADPT
- D:DVBCIE="E" ;external Last MSE data
- . S DVBMSE=$P($G(VASV(6,4)),U,2)_"^"_$P($G(VASV(6,5)),U,2)_"^"
- . S DVBMSE=DVBMSE_$P($G(VASV(6,1)),U,2)_"^"_$P($G(VASV(6,3)),U,2)
- D:DVBCIE="I" ;internal Last MSE data
- . S DVBMSE=$P($G(VASV(6,4)),U)_"^"_$P($G(VASV(6,5)),U)_"^"
- . S DVBMSE=DVBMSE_$P($G(VASV(6,1)),U)_"^"_$P($G(VASV(6,3)),U)
- Q DVBMSE
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTIL 8150 printed Jan 18, 2025@02:50:24 Page 2
- 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
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- KILL ;common exit
- +1 DO ^%ZISC
- IF $DATA(FF)
- IF '$DATA(ZTQUEUED)
- WRITE @FF,!!
- +2 KILL %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
- +3 KILL 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
- +4 KILL DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
- +5 KILL DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
- +6 KILL COUNTY,PROVINCE,POSTALCD,COUNTRY
- +7 GOTO KILL^DVBCUTL2
- +8 ;
- DICW ;used on ^DIC lookups only
- +1 WRITE !
- SET TSTDT=$PIECE(^(0),U,2)
- SET RO=$PIECE(^(0),U,3)
- SET STAT=$PIECE(^(0),U,18)
- SET RONAME=$SELECT($DATA(^DIC(4,+RO,0)):$PIECE(^(0),U,1),1:"Unknown RO")
- DO DICW1
- +2 WRITE !
- QUIT
- +3 ;
- DICW1 FOR JY=0:0
- SET JY=$ORDER(^DVB(396.4,"C",+Y,JY))
- if JY=""
- QUIT
- SET EXAM=$PIECE(^DVB(396.4,+JY,0),U,3)
- SET EXAM=$SELECT($DATA(^DVB(396.6,EXAM,0)):$PIECE(^(0),U,1),1:"Unknown exam")
- DO DICW2
- +1 QUIT
- +2 ;
- DICW2 WRITE ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
- +1 QUIT
- +2 ;
- VARS SET DTA=^DVB(396.3,DA,0)
- SET DFN=$PIECE(DTA,U,1)
- SET (NAME,PNAM)=$PIECE(^DPT(DFN,0),U,1)
- SET DOB=$PIECE(^(0),U,3)
- SET SEX=$PIECE(^(0),U,2)
- SET SSN=$PIECE(^(0),U,9)
- SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Unknown")
- SET DTRQ=$PIECE(DTA,U,2)
- +1 SET RO=$PIECE(DTA,U,3)
- SET FEXM=$PIECE(DTA,U,9)
- if RO=""
- SET RO=0
- SET RONAME=$SELECT($DATA(^DIC(4,RO,0)):$PIECE(^(0),U,1),1:"Unknown")
- +2 SET REQN=$PIECE(DTA,U,4)
- SET REQN=$SELECT($DATA(^VA(200,+REQN,0)):$PIECE(^(0),U,1),1:"Unknown")
- SET OTHDIS=$PIECE(DTA,U,11)
- IF $DATA(^DVB(396.3,DA,1))
- SET OTHDIS1=$PIECE(^(1),U,9)
- SET OTHDIS2=$PIECE(^(1),U,10)
- +3 SET ZPR=$PIECE(DTA,U,10)
- SET PRIO=""
- Begin DoDot:1
- +4 IF ZPR="T"
- SET PRIO="Terminal"
- QUIT
- +5 IF ZPR="P"
- SET PRIO="Prisoner of war"
- QUIT
- +6 IF ZPR="OS"
- SET PRIO="Original SC"
- QUIT
- +7 IF ZPR="ON"
- SET PRIO="Original NSC"
- QUIT
- +8 IF ZPR="I"
- SET PRIO="Increase"
- QUIT
- +9 IF ZPR="R"
- SET PRIO="Review"
- QUIT
- +10 IF ZPR="OTR"
- SET PRIO="Other"
- QUIT
- +11 IF ZPR="E"
- SET PRIO="Inadequate exam"
- QUIT
- +12 IF ZPR="AO"
- SET PRIO="Agent Orange"
- QUIT
- +13 IF ZPR="BDD"
- SET PRIO="Ben Deliv at Disch"
- QUIT
- +14 IF ZPR="IDES"
- SET PRIO="IDES"
- QUIT
- +15 IF ZPR="QS"
- SET PRIO="Quick Start"
- End DoDot:1
- if PRIO']""
- SET PRIO="Unknown"
- +16 KILL DVBAINSF
- if ZPR="E"
- SET DVBAINSF=""
- +17 SET (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
- +18 IF $DATA(^DPT(DFN,.11))
- Begin DoDot:1
- +19 SET DTA=^DPT(DFN,.11)
- +20 SET ADR1=$PIECE(DTA,U,1)
- SET ADR2=$PIECE(DTA,U,2)
- SET ADR3=$PIECE(DTA,U,3)
- SET CITY=$PIECE(DTA,U,4)
- +21 SET ZIP=$PIECE(DTA,U,12)
- if ZIP'=""
- SET ZIP=$SELECT($LENGTH(ZIP)>5:$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,9),1:ZIP)
- IF ZIP=""
- SET ZIP="No Zip"
- +22 SET CITY=$SELECT(CITY]"":CITY,1:"Unknown")
- SET STATE=$PIECE(DTA,U,5)
- IF STATE]""
- SET STATE=$SELECT($DATA(^DIC(5,STATE,0)):$PIECE(^(0),U,1),1:"Unknown")
- +23 SET COUNTY=$PIECE(DTA,U,7)
- SET PROVINCE=$PIECE(DTA,U,8)
- SET POSTALCD=$PIECE(DTA,U,9)
- +24 SET COUNTRY=$PIECE(DTA,U,10)
- End DoDot:1
- +25 SET (HOMPHON,BUSPHON)="Unknown"
- IF $DATA(^DPT(DFN,.13))
- SET HOMPHON=$PIECE(^(.13),U,1)
- SET BUSPHON=$PIECE(^(.13),U,2)
- +26 ;DVBA/126 added
- IF $DATA(^DPT(DFN,.121))
- Begin DoDot:1
- +27 SET (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
- +28 SET DTT=^DPT(DFN,.121)
- +29 SET TAD1=$PIECE(DTT,U,1)
- SET TAD2=$PIECE(DTT,U,2)
- SET TAD3=$PIECE(DTT,U,3)
- SET TCITY=$PIECE(DTT,U,4)
- +30 SET TZIP=$PIECE(DTT,U,12)
- if TZIP'=""
- SET TZIP=$SELECT($LENGTH(TZIP)>5:$EXTRACT(TZIP,1,5)_"-"_$EXTRACT(TZIP,6,9),1:TZIP)
- IF TZIP=""
- SET TZIP="No Zip"
- +31 SET TCITY=$SELECT(TCITY]"":TCITY,1:"Unknown")
- SET TST=$PIECE(DTT,U,5)
- IF TST]""
- SET TST=$SELECT($DATA(^DIC(5,TST,0)):$PIECE(^(0),U,1),1:"Unknown")
- +32 SET TPHONE=$PIECE(DTT,U,10)
- if TPHONE=""
- SET TPHONE="Unknown"
- End DoDot:1
- +33 SET EDTA=$$SVC(DFN,"I")
- SET EOD=$PIECE(EDTA,U)
- SET RAD=$PIECE(EDTA,U,2)
- SET Y=$SELECT($DATA(^DVB(396.3,DA,1)):$PIECE(^(1),U,7),1:"")
- XECUTE ^DD("DD")
- SET LREXMDT=Y
- +34 QUIT
- +35 ;
- HDR WRITE @FF,?(IOM-$LENGTH(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
- +1 SET JII=""
- +2 FOR JIJ=0:0
- SET JII=$ORDER(^TMP($JOB,JII))
- if JII=""
- QUIT
- SET XST=$PIECE(^TMP($JOB,JII),U,1)
- WRITE JII,", ",$SELECT(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", "
- IF $X>30
- WRITE !
- +3 QUIT
- +4 ;
- ADDR ;
- +1 NEW ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE
- +2 NEW PRDSV,ELIG,INCMP
- +3 SET (ADD1,ADD2,ADD3,CITY,CNTY,STATE,ZIP,COUNTRY,POSTCODE,PROVINCE)=""
- +4 IF $DATA(^DPT(DFN,.11))
- SET DTA=^(.11)
- SET ADD1=$PIECE(DTA,U,1)
- SET ADD2=$PIECE(DTA,U,2)
- SET ADD3=$PIECE(DTA,U,3)
- SET CITY=$PIECE(DTA,U,4)
- SET STATE=$PIECE(DTA,U,5)
- SET ZIP=$PIECE(DTA,U,12)
- SET CNTY=$PIECE(DTA,U,7)
- SET PROVINCE=$PIECE(DTA,U,8)
- SET POSTCODE=$PIECE(DTA,U,9)
- SET COUNTRY=$PIECE(DTA,U,10)
- +5 WRITE !!?0,"Address: ",?14,ADD1,!
- +6 if ADD2]""
- WRITE ?14,ADD2,!
- +7 if ADD3]""
- WRITE ?14,ADD3,!
- +8 ;Functionality for USA Unique Address Output
- +9 if $$ISFORGN(COUNTRY)'>0
- Begin DoDot:1
- +10 if ZIP'=""
- SET ZIP=$SELECT($LENGTH(ZIP)>5:$EXTRACT(ZIP,1,5)_"-"_$EXTRACT(ZIP,6,9),1:ZIP)
- +11 SET CNTY=$SELECT($DATA(^DIC(5,+STATE,1,+CNTY,0)):$PIECE(^(0),U,1),1:"Unknown")
- +12 SET STATE=$SELECT($DATA(^DIC(5,+STATE,0)):$PIECE(^(0),U,1),1:"Unknown")
- +13 WRITE ?0,"City:",?14,CITY," ",STATE," ",ZIP,!?0,"County:",?14,CNTY,!
- End DoDot:1
- +14 ;Functionality for Foreign Unique Address Output
- +15 if $$ISFORGN(COUNTRY)>0
- Begin DoDot:1
- +16 IF POSTCODE=""
- SET POSTCODE="Unknown"
- +17 IF CITY=""
- SET CITY="Unknown"
- +18 IF PROVINCE=""
- SET PROVINCE="Unknown"
- +19 WRITE ?0,"Postal Code:",?14,POSTCODE,!?0,"City:",?14,CITY,!?0,"Province: ",?14,PROVINCE,!
- End DoDot:1
- +20 if COUNTRY>0
- WRITE ?0,"Country:",?14,$$GETCNTRY(+COUNTRY),!
- +21 WRITE !
- +22 SET PRDSV=$SELECT($DATA(^DPT(DFN,.32)):$PIECE(^(.32),U,3),1:"")
- IF PRDSV]""
- SET PRDSV=$PIECE(^DIC(21,PRDSV,0),U,1)
- +23 WRITE "Period of service: ",PRDSV,!
- +24 SET ELIG=""
- SET INCMP=0
- +25 WRITE ?0,"Eligibility data:"
- IF $DATA(^DPT(DFN,.36))
- IF $PIECE(^(.36),U,1)]""
- SET ELIG=$SELECT($DATA(^DIC(8,+^(.36),0)):$PIECE(^(0),U,6),1:"")
- +26 IF ELIG]""
- IF $DATA(^DPT(DFN,.361))
- IF ^(.361)]""
- SET ELIG=ELIG_" ("_$SELECT($PIECE(^(.361),U,1)="P":"Pend ver",$PIECE(^(.361),U,1)="R":"Pend re-verif",$PIECE(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
- +27 IF $DATA(^DPT(DFN,.29))
- IF $PIECE(^(.29),U,1)]""
- SET INCMP=1
- +28 IF $DATA(^DPT(DA,.293))
- IF $PIECE(^(.293),U,1)=1
- SET INCMP=1
- +29 WRITE ?19,ELIG_$SELECT(ELIG]"":", ",1:"")_$SELECT(INCMP=1:"Incompetent",1:""),!
- +30 QUIT
- +31 ;
- SSNSHRT ; ** Set SSN in the Format '123 45 6789' **
- +1 KILL DVBCSSNO
- +2 SET DVBCSSNO=$EXTRACT(SSN,1,3)_" "_$EXTRACT(SSN,4,5)_" "_$EXTRACT(SSN,6,9)
- +3 QUIT
- +4 ;
- SSNOUT ; ** Set SSN in the Format '123 45 6789 (Z6789) **
- +1 DO SSNSHRT
- +2 SET DVBCSSNO=DVBCSSNO_" ("_$EXTRACT(PNAM)_$EXTRACT(SSN,6,9)_")"
- +3 QUIT
- +4 ;
- ISFORGN(DVBIEN) ; ** Is country entry foreign? **
- +1 ; Input: DVBIEN - IEN of COUNTRY CODE file
- +2 ;
- +3 ; Output: Return 1 when country is foreign
- +4 ; Return 0 when country is not foreign
- +5 ; Return -1 on error
- +6 ;
- +7 NEW DVBCNTRY
- +8 NEW DVBERR
- +9 if $GET(DVBIEN)=""
- QUIT -1
- +10 SET DVBCNTRY=$$GET1^DIQ(779.004,DVBIEN_",",".01","","","DVBERR")
- +11 QUIT $SELECT($DATA(DVBERR):-1,DVBCNTRY="USA":0,1:1)
- +12 ;
- GETCNTRY(DVBIEN) ; ** Get POSTAL NAME for country code **
- +1 ; Input: DVBIEN - IEN of COUNTRY CODE file
- +2 ;
- +3 ; Output: Return POSTAL NAME field on success or
- +4 ; DESCRIPTION field when POSTAL NAME = "<NULL>";
- +5 ; Otherwise, return "" on failure.
- +6 ;
- +7 NEW DVBCNTRY
- +8 NEW DVBERR
- +9 NEW DVBIENS
- +10 NEW DVBNAME
- +11 SET DVBNAME=""
- +12 IF $GET(DVBIEN)'=""
- Begin DoDot:1
- +13 SET DVBIENS=DVBIEN_","
- +14 DO GETS^DIQ(779.004,DVBIENS,"1.3;2","E","DVBCNTRY","DVBERR")
- +15 IF '$DATA(DVBERR)
- Begin DoDot:2
- +16 SET DVBNAME=$GET(DVBCNTRY(779.004,DVBIENS,1.3,"E"))
- +17 IF DVBNAME="<NULL>"
- SET DVBNAME=$$UP^XLFSTR($GET(DVBCNTRY(779.004,DVBIENS,2,"E")))
- End DoDot:2
- End DoDot:1
- +18 QUIT DVBNAME
- +19 ;
- SVC(DFN,DVBCIE) ;Retrieve Last Military Service Data Info
- +1 ; Using supported API SVC^VAPDT, which encapsulates the
- +2 ; Military Service Episode (MSE) changes due to the
- +3 ; Enrollment Military Service Data Sharing (MSDS) project
- +4 ; (Patch DG*5.3*797)
- +5 ; INPUT
- +6 ; DFN - Patient (#2) file internal entry number (Required)
- +7 ; DVBCIE - "I" to return service dates in Fileman format (Default)
- +8 ; "E" to return servce dates in external format
- +9 ; OUTPUT
- +10 ; Returns '^' delimitted string
- +11 ; 1. Last Service Entry Date
- +12 ; 2. Last Service Seperation Date
- +13 ; 3. Last Service Branch
- +14 ; 4. Last Service Discharge Type
- +15 ;
- +16 ;Quit if DFN not greater than zero
- +17 if ($GET(DFN)'>0)
- QUIT ""
- +18 ;If DVBCIE not "I" or "E" set to default of "I"
- +19 if "^I^E^"'[(U_$GET(DVBCIE)_U)
- SET DVBCIE="I"
- +20 NEW VASV,VAHOW,VAROOT,DVBMSE
- +21 DO SVC^VADPT
- +22 ;external Last MSE data
- if DVBCIE="E"
- Begin DoDot:1
- +23 SET DVBMSE=$PIECE($GET(VASV(6,4)),U,2)_"^"_$PIECE($GET(VASV(6,5)),U,2)_"^"
- +24 SET DVBMSE=DVBMSE_$PIECE($GET(VASV(6,1)),U,2)_"^"_$PIECE($GET(VASV(6,3)),U,2)
- End DoDot:1
- +25 ;internal Last MSE data
- if DVBCIE="I"
- Begin DoDot:1
- +26 SET DVBMSE=$PIECE($GET(VASV(6,4)),U)_"^"_$PIECE($GET(VASV(6,5)),U)_"^"
- +27 SET DVBMSE=DVBMSE_$PIECE($GET(VASV(6,1)),U)_"^"_$PIECE($GET(VASV(6,3)),U)
- End DoDot:1
- +28 QUIT DVBMSE