VAQDBIP7 ;ALB/JRP - CONTINUATION FOR VAQDBIP4: 3/17/2004
;;1.5;PATIENT DATA EXCHANGE;**13,42**;NOV 17, 1993
INSURE ;INSURANCE EXTRACTION (ALL NON-EXPIRED)
; DECLARATIONS DONE IN VAQDBIP4
;GET LIST OF FIELDS TO EXTRACT
S TMP=$T(INSURE+1^VAQDBII1)
S FLDS(1)=$TR($P(TMP,";",4),",",";")
S TMP=$T(INSURE+2^VAQDBII1)
S FLDS(2)=$TR($P(TMP,";",4),",",";")
S TMP=$T(INSURE+3^VAQDBII1)
S FLDS(3)=$TR($P(TMP,";",4),",",";")
;ENCRYPT PATIENT NAME (ID FOR INSURANCE COMPANY & GROUP PLAN)
S STRING=$P($$PATINFO^VAQUTL1(DFN),U,1)
S ENCSTR=STRING
I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
S NAME=ENCSTR
N VAQINS
;DETERMINE IF COVERED BY HEALTH INSURANCE & ENCRYPT
;S TMP=$$INSUR^IBBAPI(DFN,DT,"R",.VAQINS,"1,2,3,4,5,6,8,10,11,12,13,14,18") ; Get all active (not expired) insurance, reimbursable or not
S TMP=$$INSUR^IBBAPI(DFN,"","ARB",.VAQINS,"1,2,3,4,5,6,8,10,11,12,13,14,18") ; Get all insurance, expired or not, reimbursable or not
S STRING=$S(TMP:"YES",1:"NO")
S ENCSTR=STRING
I $$NCRPFLD^VAQUTL2(2,.3192) X ENCRYPT
;GET SEQUENCE NUMBER & STORE INFO
S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2,.3192)
S @ARRAY@("ID",2,.3192,SEQ)=NAME
S @ARRAY@("VALUE",2,.3192,SEQ)=ENCSTR
;EXTRACT DATA
K ^UTILITY("DIQ1",$J)
S TMP=0
F S TMP=$O(VAQINS("IBBAPI","INSUR",TMP)) Q:'TMP D
.;EXTRACT INSURANCE INFO
.;Prior to patch *42, we took the info directly from file 2.
.;Now we get it from the IB API call.
.;PATIENT (#2) file
.;INSURANCE TYPE (#2.312) Subfile API field equivalent
.;------------------------------------------ --------------------
.;.01 INSURANCE TYPE (ptr to file 36) 1 insurance company name
.;.18 GROUP PLAN (ptr to file 355.3) --
.;1 SUBSCRIBER ID 14 subscriber ID
.;2 *GROUP NUMBER --
.;3 INSURANCE EXPIRATION DATE 11 expiration date
.;6 WHOSE INSURANCE (v=vet;s=spouse;o=other)12 subscriber relationship
.;7 *RENEWAL DATE --
.;8 EFFECTIVE DATE OF POLICY 10 effective date
.;16 PT. RELATIONSHIP TO INSURED 12 subscriber relationship
.;17 NAME OF INSURED 13 subscriber name
.S ^UTILITY("DIQ1",$J,2.312,TMP,.01,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
.S ^UTILITY("DIQ1",$J,2.312,TMP,1,"E")=VAQINS("IBBAPI","INSUR",TMP,14)
.S ^UTILITY("DIQ1",$J,2.312,TMP,3,"E")=$$FMTE^XLFDT(VAQINS("IBBAPI","INSUR",TMP,11))
.I VAQINS("IBBAPI","INSUR",TMP,12)[U S ^UTILITY("DIQ1",$J,2.312,TMP,6,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,12),U,2)
.E S ^UTILITY("DIQ1",$J,2.312,TMP,6,"E")=VAQINS("IBBAPI","INSUR",TMP,12)
.S ^UTILITY("DIQ1",$J,2.312,TMP,8,"E")=$$FMTE^XLFDT(VAQINS("IBBAPI","INSUR",TMP,10))
.S ^UTILITY("DIQ1",$J,2.312,TMP,16,"E")=^UTILITY("DIQ1",$J,2.312,TMP,6,"E")
.S ^UTILITY("DIQ1",$J,2.312,TMP,17,"E")=VAQINS("IBBAPI","INSUR",TMP,13)
.;EXTRACT INFO ABOUT INSURANCE COMPANY
.;Prior to patch *42, we took the info directly from file 36.
.;Now we get it from the IB API call.
.;INSURANCE COMPANY (#36) file API field equivalent
.;------------------------------------------ --------------------
.;.01 NAME 1 insurance company name
.;.111 STREET ADDRESS [LINE 1] 2 street address
.;.112 STREET ADDRESS [LINE 2] -
.;.113 STREET ADDRESS [LINE 3] -
.;.114 CITY 3 city
.;.115 STATE 4 state
.;.316 ZIP 5 zip
.;.131 PHONE NUMBER 6 phone number
.S ^UTILITY("DIQ1",$J,36,TMP,.01,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
.S ^UTILITY("DIQ1",$J,36,TMP,.111,"E")=VAQINS("IBBAPI","INSUR",TMP,2)
.S ^UTILITY("DIQ1",$J,36,TMP,.114,"E")=VAQINS("IBBAPI","INSUR",TMP,3)
.S ^UTILITY("DIQ1",$J,36,TMP,.115,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,4),U,2)
.S ^UTILITY("DIQ1",$J,36,TMP,.316,"E")=VAQINS("IBBAPI","INSUR",TMP,5)
.S ^UTILITY("DIQ1",$J,36,TMP,.131,"E")=VAQINS("IBBAPI","INSUR",TMP,6)
.;EXTRACT INFO ABOUT GROUP PLAN
.;Prior to patch *42, we took the info directly from file 355.3.
.;Now we get it from the IB API call.
.;GROUP INSURANCE PLAN (#355.3) file API field equivalent
.;------------------------------------------ --------------------
.;.01 INSURANCE COMPANY (ptr to file 36) 1 insurance company name
.;.02 IS THIS A GROUP POLICY? (1=yes/0=no) -
.;.03 GROUP NAME 8 policy IEN and name
.;.04 GROUP NUMBER 18 policy number
.;.1 INDIVIDUAL POLICY PATIENT (ptr to file 2)-
.S ^UTILITY("DIQ1",$J,355.3,TMP,.01,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
.S ^UTILITY("DIQ1",$J,355.3,TMP,.03,"E")=$P(VAQINS("IBBAPI","INSUR",TMP,8),U,2)
.S ^UTILITY("DIQ1",$J,355.3,TMP,.04,"E")=VAQINS("IBBAPI","INSUR",TMP,18)
.;GET SEQUENCE NUMBER FOR INSURANCE
.S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.312,.01)
.;ENCRYPT COMPANY NAME
.S STRING=$G(^UTILITY("DIQ1",$J,2.312,TMP,.01,"E"))
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(2.312,.01) X ENCRYPT
.S PRIME=ENCSTR
.;STORE COMPANY NAME/ID
.S @ARRAY@("ID",2.312,.01,SEQ)=NAME
.S @ARRAY@("VALUE",2.312,.01,SEQ)=PRIME
.F X=1:1:$L(FLDS(1),";") D
..S Z=$P(FLDS(1),";",X)
..Q:(Z=.01)
..;STORE ID (COMPANY NAME)
..S @ARRAY@("ID",2.312,Z,SEQ)=PRIME
..;ENCRYPT/STORE VALUE
..S STRING=$G(^UTILITY("DIQ1",$J,2.312,TMP,Z,"E"))
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(2.312,Z) X ENCRYPT
..S @ARRAY@("VALUE",2.312,Z,SEQ)=ENCSTR
.;GET SEQUENCE NUMBER FOR COMPANY
.S SEQ=$$GETSEQ^VAQDBIP(ARRAY,36,.01)
.;ENCRYPT COMPANY NAME
.S STRING=$G(^UTILITY("DIQ1",$J,36,TMP,.01,"E"))
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(36,.01) X ENCRYPT
.S PRIME=ENCSTR
.;STORE COMPANY NAME/ID
.S @ARRAY@("ID",36,.01,SEQ)=NAME
.S @ARRAY@("VALUE",36,.01,SEQ)=PRIME
.F X=1:1:$L(FLDS(2),";") D
..S Z=$P(FLDS(2),";",X)
..Q:(Z=.01)
..;STORE ID (COMPANY NAME)
..S @ARRAY@("ID",36,Z,SEQ)=PRIME
..;ENCRYPT/STORE VALUE
..S STRING=$G(^UTILITY("DIQ1",$J,36,TMP,Z,"E"))
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(36,Z) X ENCRYPT
..S @ARRAY@("VALUE",36,Z,SEQ)=ENCSTR
.;GET SEQUENCE NUMBER FOR GROUP PLAN
.S SEQ=$$GETSEQ^VAQDBIP(ARRAY,355.3,.01)
.;ENCRYPT PLAN NAME
.S STRING=$G(^UTILITY("DIQ1",$J,355.3,TMP,.01,"E"))
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(355.3,.01) X ENCRYPT
.S PRIME=ENCSTR
.;STORE PLAN NAME/ID
.S @ARRAY@("ID",355.3,.01,SEQ)=NAME
.S @ARRAY@("VALUE",355.3,.01,SEQ)=PRIME
.F X=1:1:$L(FLDS(3),";") D
..S Z=$P(FLDS(3),";",X)
..Q:(Z=.01)
..;STORE ID (PLAN NAME)
..S @ARRAY@("ID",355.3,Z,SEQ)=PRIME
..;ENCRYPT/STORE VALUE
..S STRING=$G(^UTILITY("DIQ1",$J,355.3,TMP,Z,"E"))
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(355.3,Z) X ENCRYPT
..S @ARRAY@("VALUE",355.3,Z,SEQ)=ENCSTR
.K ^UTILITY("DIQ1",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP7 6922 printed Sep 23, 2025@20:00:54 Page 2
VAQDBIP7 ;ALB/JRP - CONTINUATION FOR VAQDBIP4: 3/17/2004
+1 ;;1.5;PATIENT DATA EXCHANGE;**13,42**;NOV 17, 1993
INSURE ;INSURANCE EXTRACTION (ALL NON-EXPIRED)
+1 ; DECLARATIONS DONE IN VAQDBIP4
+2 ;GET LIST OF FIELDS TO EXTRACT
+3 SET TMP=$TEXT(INSURE+1^VAQDBII1)
+4 SET FLDS(1)=$TRANSLATE($PIECE(TMP,";",4),",",";")
+5 SET TMP=$TEXT(INSURE+2^VAQDBII1)
+6 SET FLDS(2)=$TRANSLATE($PIECE(TMP,";",4),",",";")
+7 SET TMP=$TEXT(INSURE+3^VAQDBII1)
+8 SET FLDS(3)=$TRANSLATE($PIECE(TMP,";",4),",",";")
+9 ;ENCRYPT PATIENT NAME (ID FOR INSURANCE COMPANY & GROUP PLAN)
+10 SET STRING=$PIECE($$PATINFO^VAQUTL1(DFN),U,1)
+11 SET ENCSTR=STRING
+12 IF $$NCRPFLD^VAQUTL2(2,.01)
XECUTE ENCRYPT
+13 SET NAME=ENCSTR
+14 NEW VAQINS
+15 ;DETERMINE IF COVERED BY HEALTH INSURANCE & ENCRYPT
+16 ;S TMP=$$INSUR^IBBAPI(DFN,DT,"R",.VAQINS,"1,2,3,4,5,6,8,10,11,12,13,14,18") ; Get all active (not expired) insurance, reimbursable or not
+17 ; Get all insurance, expired or not, reimbursable or not
SET TMP=$$INSUR^IBBAPI(DFN,"","ARB",.VAQINS,"1,2,3,4,5,6,8,10,11,12,13,14,18")
+18 SET STRING=$SELECT(TMP:"YES",1:"NO")
+19 SET ENCSTR=STRING
+20 IF $$NCRPFLD^VAQUTL2(2,.3192)
XECUTE ENCRYPT
+21 ;GET SEQUENCE NUMBER & STORE INFO
+22 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,2,.3192)
+23 SET @ARRAY@("ID",2,.3192,SEQ)=NAME
+24 SET @ARRAY@("VALUE",2,.3192,SEQ)=ENCSTR
+25 ;EXTRACT DATA
+26 KILL ^UTILITY("DIQ1",$JOB)
+27 SET TMP=0
+28 FOR
SET TMP=$ORDER(VAQINS("IBBAPI","INSUR",TMP))
if 'TMP
QUIT
Begin DoDot:1
+29 ;EXTRACT INSURANCE INFO
+30 ;Prior to patch *42, we took the info directly from file 2.
+31 ;Now we get it from the IB API call.
+32 ;PATIENT (#2) file
+33 ;INSURANCE TYPE (#2.312) Subfile API field equivalent
+34 ;------------------------------------------ --------------------
+35 ;.01 INSURANCE TYPE (ptr to file 36) 1 insurance company name
+36 ;.18 GROUP PLAN (ptr to file 355.3) --
+37 ;1 SUBSCRIBER ID 14 subscriber ID
+38 ;2 *GROUP NUMBER --
+39 ;3 INSURANCE EXPIRATION DATE 11 expiration date
+40 ;6 WHOSE INSURANCE (v=vet;s=spouse;o=other)12 subscriber relationship
+41 ;7 *RENEWAL DATE --
+42 ;8 EFFECTIVE DATE OF POLICY 10 effective date
+43 ;16 PT. RELATIONSHIP TO INSURED 12 subscriber relationship
+44 ;17 NAME OF INSURED 13 subscriber name
+45 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,.01,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
+46 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,1,"E")=VAQINS("IBBAPI","INSUR",TMP,14)
+47 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,3,"E")=$$FMTE^XLFDT(VAQINS("IBBAPI","INSUR",TMP,11))
+48 IF VAQINS("IBBAPI","INSUR",TMP,12)[U
SET ^UTILITY("DIQ1",$JOB,2.312,TMP,6,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,12),U,2)
+49 IF '$TEST
SET ^UTILITY("DIQ1",$JOB,2.312,TMP,6,"E")=VAQINS("IBBAPI","INSUR",TMP,12)
+50 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,8,"E")=$$FMTE^XLFDT(VAQINS("IBBAPI","INSUR",TMP,10))
+51 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,16,"E")=^UTILITY("DIQ1",$JOB,2.312,TMP,6,"E")
+52 SET ^UTILITY("DIQ1",$JOB,2.312,TMP,17,"E")=VAQINS("IBBAPI","INSUR",TMP,13)
+53 ;EXTRACT INFO ABOUT INSURANCE COMPANY
+54 ;Prior to patch *42, we took the info directly from file 36.
+55 ;Now we get it from the IB API call.
+56 ;INSURANCE COMPANY (#36) file API field equivalent
+57 ;------------------------------------------ --------------------
+58 ;.01 NAME 1 insurance company name
+59 ;.111 STREET ADDRESS [LINE 1] 2 street address
+60 ;.112 STREET ADDRESS [LINE 2] -
+61 ;.113 STREET ADDRESS [LINE 3] -
+62 ;.114 CITY 3 city
+63 ;.115 STATE 4 state
+64 ;.316 ZIP 5 zip
+65 ;.131 PHONE NUMBER 6 phone number
+66 SET ^UTILITY("DIQ1",$JOB,36,TMP,.01,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
+67 SET ^UTILITY("DIQ1",$JOB,36,TMP,.111,"E")=VAQINS("IBBAPI","INSUR",TMP,2)
+68 SET ^UTILITY("DIQ1",$JOB,36,TMP,.114,"E")=VAQINS("IBBAPI","INSUR",TMP,3)
+69 SET ^UTILITY("DIQ1",$JOB,36,TMP,.115,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,4),U,2)
+70 SET ^UTILITY("DIQ1",$JOB,36,TMP,.316,"E")=VAQINS("IBBAPI","INSUR",TMP,5)
+71 SET ^UTILITY("DIQ1",$JOB,36,TMP,.131,"E")=VAQINS("IBBAPI","INSUR",TMP,6)
+72 ;EXTRACT INFO ABOUT GROUP PLAN
+73 ;Prior to patch *42, we took the info directly from file 355.3.
+74 ;Now we get it from the IB API call.
+75 ;GROUP INSURANCE PLAN (#355.3) file API field equivalent
+76 ;------------------------------------------ --------------------
+77 ;.01 INSURANCE COMPANY (ptr to file 36) 1 insurance company name
+78 ;.02 IS THIS A GROUP POLICY? (1=yes/0=no) -
+79 ;.03 GROUP NAME 8 policy IEN and name
+80 ;.04 GROUP NUMBER 18 policy number
+81 ;.1 INDIVIDUAL POLICY PATIENT (ptr to file 2)-
+82 SET ^UTILITY("DIQ1",$JOB,355.3,TMP,.01,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,1),U,2)
+83 SET ^UTILITY("DIQ1",$JOB,355.3,TMP,.03,"E")=$PIECE(VAQINS("IBBAPI","INSUR",TMP,8),U,2)
+84 SET ^UTILITY("DIQ1",$JOB,355.3,TMP,.04,"E")=VAQINS("IBBAPI","INSUR",TMP,18)
+85 ;GET SEQUENCE NUMBER FOR INSURANCE
+86 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.312,.01)
+87 ;ENCRYPT COMPANY NAME
+88 SET STRING=$GET(^UTILITY("DIQ1",$JOB,2.312,TMP,.01,"E"))
+89 SET ENCSTR=STRING
+90 IF $$NCRPFLD^VAQUTL2(2.312,.01)
XECUTE ENCRYPT
+91 SET PRIME=ENCSTR
+92 ;STORE COMPANY NAME/ID
+93 SET @ARRAY@("ID",2.312,.01,SEQ)=NAME
+94 SET @ARRAY@("VALUE",2.312,.01,SEQ)=PRIME
+95 FOR X=1:1:$LENGTH(FLDS(1),";")
Begin DoDot:2
+96 SET Z=$PIECE(FLDS(1),";",X)
+97 if (Z=.01)
QUIT
+98 ;STORE ID (COMPANY NAME)
+99 SET @ARRAY@("ID",2.312,Z,SEQ)=PRIME
+100 ;ENCRYPT/STORE VALUE
+101 SET STRING=$GET(^UTILITY("DIQ1",$JOB,2.312,TMP,Z,"E"))
+102 SET ENCSTR=STRING
+103 IF $$NCRPFLD^VAQUTL2(2.312,Z)
XECUTE ENCRYPT
+104 SET @ARRAY@("VALUE",2.312,Z,SEQ)=ENCSTR
End DoDot:2
+105 ;GET SEQUENCE NUMBER FOR COMPANY
+106 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,36,.01)
+107 ;ENCRYPT COMPANY NAME
+108 SET STRING=$GET(^UTILITY("DIQ1",$JOB,36,TMP,.01,"E"))
+109 SET ENCSTR=STRING
+110 IF $$NCRPFLD^VAQUTL2(36,.01)
XECUTE ENCRYPT
+111 SET PRIME=ENCSTR
+112 ;STORE COMPANY NAME/ID
+113 SET @ARRAY@("ID",36,.01,SEQ)=NAME
+114 SET @ARRAY@("VALUE",36,.01,SEQ)=PRIME
+115 FOR X=1:1:$LENGTH(FLDS(2),";")
Begin DoDot:2
+116 SET Z=$PIECE(FLDS(2),";",X)
+117 if (Z=.01)
QUIT
+118 ;STORE ID (COMPANY NAME)
+119 SET @ARRAY@("ID",36,Z,SEQ)=PRIME
+120 ;ENCRYPT/STORE VALUE
+121 SET STRING=$GET(^UTILITY("DIQ1",$JOB,36,TMP,Z,"E"))
+122 SET ENCSTR=STRING
+123 IF $$NCRPFLD^VAQUTL2(36,Z)
XECUTE ENCRYPT
+124 SET @ARRAY@("VALUE",36,Z,SEQ)=ENCSTR
End DoDot:2
+125 ;GET SEQUENCE NUMBER FOR GROUP PLAN
+126 SET SEQ=$$GETSEQ^VAQDBIP(ARRAY,355.3,.01)
+127 ;ENCRYPT PLAN NAME
+128 SET STRING=$GET(^UTILITY("DIQ1",$JOB,355.3,TMP,.01,"E"))
+129 SET ENCSTR=STRING
+130 IF $$NCRPFLD^VAQUTL2(355.3,.01)
XECUTE ENCRYPT
+131 SET PRIME=ENCSTR
+132 ;STORE PLAN NAME/ID
+133 SET @ARRAY@("ID",355.3,.01,SEQ)=NAME
+134 SET @ARRAY@("VALUE",355.3,.01,SEQ)=PRIME
+135 FOR X=1:1:$LENGTH(FLDS(3),";")
Begin DoDot:2
+136 SET Z=$PIECE(FLDS(3),";",X)
+137 if (Z=.01)
QUIT
+138 ;STORE ID (PLAN NAME)
+139 SET @ARRAY@("ID",355.3,Z,SEQ)=PRIME
+140 ;ENCRYPT/STORE VALUE
+141 SET STRING=$GET(^UTILITY("DIQ1",$JOB,355.3,TMP,Z,"E"))
+142 SET ENCSTR=STRING
+143 IF $$NCRPFLD^VAQUTL2(355.3,Z)
XECUTE ENCRYPT
+144 SET @ARRAY@("VALUE",355.3,Z,SEQ)=ENCSTR
End DoDot:2
+145 KILL ^UTILITY("DIQ1",$JOB)
End DoDot:1
+146 QUIT
