DVBHIQM ;ISC-ALBANY/PKE,DLM,PHH/WASH-MAIL DELIVERY PROGRAM ;3/23/06
;;4.0;HINQ;**49,57,61**;03/25/92;Build 19
G EN
LIN Q:CT>50 S CT=CT+1,A1=A_CT_",0)",@A1=T1 Q
DD S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".") Q
;
EN I $D(X(1)),$E(X(1),1,5)'="ERROR" S DFN=$E(X(1),8,21),XMDUZ=.5,XMSUB="HINQ response for " I DFN?14"0" S DFN=0,XMSUB="HINQ Transaction Test "
I DFN'?14" " K DVBREQST
S DFN=+DFN I $D(DUZ) S XMORIG=DUZ
E QUIT
I '+XMORIG QUIT
;
S (DVBASK,DVBASKER)=0
I DFN=0 G SUBJ
;
MAILGP K XMY,DVBXMY
I $D(^XMB(3.8,"B","DVBHINQ")) S N=0,N=$O(^("DVBHINQ",N)) Q:'N F DVBU=0:0 S DVBU=$O(^XMB(3.8,N,1,"B",DVBU)) Q:'DVBU S XMY(DVBU)=""
REQ ;
;replace direct global lookup of div with GETS^DIQ - DVB*4*49
I $D(^DVB(395.5,DFN,0)) D
. N DVBARR,DVBERR
. D GETS^DIQ(395.5,DFN_",",9,"E","DVBARR","DVBERR")
. S DVBDIV=$G(DVBARR(395.5,DFN_",",9,"E"))
F DVBU=0:0 S DVBU=$O(^DVB(395.5,DFN,1,DVBU)) Q:'DVBU S:$D(^(DVBU,0)) DVBXMY(DVBU)=$P(^(0),U,2) ;for latest requestor dvbasker
I '$D(DVBDIV) K DVBDIV
;
F DVBU=0:0 S DVBU=$O(DVBXMY(DVBU)) Q:'DVBU I DVBXMY(DVBU)>DVBASK S DVBASK=DVBXMY(DVBU),DVBASKER=DVBU D
.I $D(^XUSEC("DVBHINQ",DVBU)) S XMY(DVBU)=""
;
SUBJ S U="^",XMY(XMORIG)="",XMSUB=XMSUB_$S($D(^DPT(DFN,0)):$P(^(0),"^",1),1:" ")_" /requested by "_$S(DVBASKER:$S($D(^VA(200,DVBASKER,0)):$P(^(0),U),1:""),1:"")_$S('DVBASKER:$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:""),1:"")
;
K ^TMP($J) S CT=0,(A,XMTEXT)="^TMP($J,",BL="",$P(BL," ",36)=" "
;
I $D(DVBREQST) S Y=DVBREQST D DATA,LIN,SEGM S T1="" D LIN
;
I $D(^DPT(DFN,0)) D DPT,LIN,WARN,SEGM
;
K DVBDIV,DVBREQST,DVBASK,DVBASKER,T9,L1,F1,F2,F3,F3,F4,F5,Y,S,S1,C,DVBXMY,DVBU,N
;exit point for errors
I $D(DVBERR) S T1=" HINQ Error = "_DVBERR D LIN
I $D(DVBERR) D ERR1
I $D(DVBERR1) S T1=" Inquiry Data Submitted = "_DVBERR1 D LIN G ERR^DVBHQM3
I $D(DVBOTM),$D(DVBNETER) S Y=DVBOTM D DD S T1=" Message out Time => "_Y D LIN
I $D(DVBNETER) S T1=" IDCU Network Error" D LIN S T1=" "_DVBNETER D LIN I $D(DVBREQUE) S Y=DVBREQUE D DD S T1=" "_"Request has been retransmitted"_$S($L(DVBREQUE):" at "_Y,1:"") D LIN G ERR^DVBHQM3
I $D(DVBNETER),'$D(DVBREQUE) S T1=" Request NOT retransmitted" D LIN G ERR^DVBHQM3
S:X(1)["HINQ" X(1)=$E(X(1),1,6) S:$D(X(2)) X(2)=$E(X(2),1,6)
;
G:$D(DVBABREV) EN^DVBHQM4
G EN^DVBHQM1
;
DPT S (S,C,T9)=""
S T1=$P(^DPT(DFN,0),U),Y=$P(^(0),U,3),T9=$P(^(0),U,9) D DD S T1=T1_" "_Y_" SSN:"_T9 S:$D(^(.31)) C=$P(^(.31),U,3) S:$D(^(.32)) S=$P(^(.32),U,8) S T1=T1_$S($L(C):" C-#:"_C,1:"")_$S($L(S):" S-#:"_S,1:"")_$S($D(DVBDIV):" Div:"_DVBDIV,1:"") Q
;
WARN Q:$D(DVBABREV) ;don't compare multiple values for abrev return
I $L(T9),$D(DVBSSN),DVBSSN?9N,+DVBSSN'=+T9 S T1="*** SSN from patient file does not match SSN from VBA ***" D LIN
I $L(C),$D(DVBCN),+DVBCN'=+C S T1="*** C-# from patient file does not match C-# from VBA ***" D LIN
I $L(S),$D(DVBSN)>9 S S1=1 F N=0:0 S N=$O(DVBSN(N)) Q:'N I +DVBSN(N)=+S K S1 Q
I $D(S1) S T1="*** S-# from Patient file does not match a S-# from VBA ***" D LIN
Q
;
SEGM Q:'$D(DVBBAS(2))
I '$P(DVBBAS(2),U,35),'$P(DVBBAS(2),U,36),'$P(DVBBAS(2),U,37),'$P(DVBBAS(2),U,38) Q
S T1=" WARNING: Error Indicators for " F N=38:-1:35 I $P(DVBBAS(2),U,N) S T1=T1_" "_$S(N=38:"BASIC",N=37:"STATISTICAL",N=36:"DIAGNOSTIC",N=35:"FUTURE",1:"")_","
S T1=$E(T1,1,$L(T1)-1) D LIN
Q
;
DATA S F1=$F(Y,"NM"),F2=$F(Y,"/",F1),F3=$F(Y,"SS",F2),F4=$F(Y,"CN",F2),F5=$F(Y,"SN",F2),T1=" Data Requested:"_$S(F1:" "_$E(Y,3,F2-2),1:"")_$S(F3:" SS# "_$E(Y,F3,F3+8),1:"")_$S(F4:" C# "_$E(Y,F4,F4+8),1:"")_$S(F5:" S# "_$E(Y,F5,F5+8),1:"") Q
ERR1 ;set inquiry info into error text
N DVBZZ,DVBZZZ
S DVBZZZ=""
S DVBZZ=$S($G(DVBZ)]"":DVBZ,$G(DVBZ0)]"":DVBZ0,$G(DVBZ1)]"":DVBZ1,1:"")
;DVB*4*54 - strip password from string before creating err msg- ERC
I $G(DVBZZ)]"",$E(DVBZZ,$L(DVBZZ)-3,$L(DVBZZ))?4U S DVBZZ=$E(DVBZZ,1,$L(DVBZZ)-4)
I DVBZZ["SS" S DVBZZZ="SS"_$E($P(DVBZZ,"SS",2),1,9)
I DVBZZ["CN" S DVBZZZ=DVBZZZ_" CN"_$E($P(DVBZZ,"CN",2),1,9)
I DVBZZ["SN" S DVBZZZ=DVBZZZ_" SN"_$E($P(DVBZZ,"SN",2),1,9)
I $G(DVBZZZ)]"" S DVBERR1=DVBZZZ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHIQM 4311 printed Nov 22, 2024@17:08:39 Page 2
DVBHIQM ;ISC-ALBANY/PKE,DLM,PHH/WASH-MAIL DELIVERY PROGRAM ;3/23/06
+1 ;;4.0;HINQ;**49,57,61**;03/25/92;Build 19
+2 GOTO EN
LIN if CT>50
QUIT
SET CT=CT+1
SET A1=A_CT_",0)"
SET @A1=T1
QUIT
DD if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
QUIT
+1 ;
EN IF $DATA(X(1))
IF $EXTRACT(X(1),1,5)'="ERROR"
SET DFN=$EXTRACT(X(1),8,21)
SET XMDUZ=.5
SET XMSUB="HINQ response for "
IF DFN?14"0"
SET DFN=0
SET XMSUB="HINQ Transaction Test "
+1 IF DFN'?14" "
KILL DVBREQST
+2 SET DFN=+DFN
IF $DATA(DUZ)
SET XMORIG=DUZ
+3 IF '$TEST
QUIT
+4 IF '+XMORIG
QUIT
+5 ;
+6 SET (DVBASK,DVBASKER)=0
+7 IF DFN=0
GOTO SUBJ
+8 ;
MAILGP KILL XMY,DVBXMY
+1 IF $DATA(^XMB(3.8,"B","DVBHINQ"))
SET N=0
SET N=$ORDER(^("DVBHINQ",N))
if 'N
QUIT
FOR DVBU=0:0
SET DVBU=$ORDER(^XMB(3.8,N,1,"B",DVBU))
if 'DVBU
QUIT
SET XMY(DVBU)=""
REQ ;
+1 ;replace direct global lookup of div with GETS^DIQ - DVB*4*49
+2 IF $DATA(^DVB(395.5,DFN,0))
Begin DoDot:1
+3 NEW DVBARR,DVBERR
+4 DO GETS^DIQ(395.5,DFN_",",9,"E","DVBARR","DVBERR")
+5 SET DVBDIV=$GET(DVBARR(395.5,DFN_",",9,"E"))
End DoDot:1
+6 ;for latest requestor dvbasker
FOR DVBU=0:0
SET DVBU=$ORDER(^DVB(395.5,DFN,1,DVBU))
if 'DVBU
QUIT
if $DATA(^(DVBU,0))
SET DVBXMY(DVBU)=$PIECE(^(0),U,2)
+7 IF '$DATA(DVBDIV)
KILL DVBDIV
+8 ;
+9 FOR DVBU=0:0
SET DVBU=$ORDER(DVBXMY(DVBU))
if 'DVBU
QUIT
IF DVBXMY(DVBU)>DVBASK
SET DVBASK=DVBXMY(DVBU)
SET DVBASKER=DVBU
Begin DoDot:1
+10 IF $DATA(^XUSEC("DVBHINQ",DVBU))
SET XMY(DVBU)=""
End DoDot:1
+11 ;
SUBJ SET U="^"
SET XMY(XMORIG)=""
SET XMSUB=XMSUB_$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),"^",1),1:" ")_" /requested by "_$SELECT(DVBASKER:$SELECT($DATA(^VA(200,DVBASKER,0)):$PIECE(^(0),U),1:""),1:"")_$SELECT('DVBASKER:$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:""),1:"")
+1 ;
+2 KILL ^TMP($JOB)
SET CT=0
SET (A,XMTEXT)="^TMP($J,"
SET BL=""
SET $PIECE(BL," ",36)=" "
+3 ;
+4 IF $DATA(DVBREQST)
SET Y=DVBREQST
DO DATA
DO LIN
DO SEGM
SET T1=""
DO LIN
+5 ;
+6 IF $DATA(^DPT(DFN,0))
DO DPT
DO LIN
DO WARN
DO SEGM
+7 ;
+8 KILL DVBDIV,DVBREQST,DVBASK,DVBASKER,T9,L1,F1,F2,F3,F3,F4,F5,Y,S,S1,C,DVBXMY,DVBU,N
+9 ;exit point for errors
+10 IF $DATA(DVBERR)
SET T1=" HINQ Error = "_DVBERR
DO LIN
+11 IF $DATA(DVBERR)
DO ERR1
+12 IF $DATA(DVBERR1)
SET T1=" Inquiry Data Submitted = "_DVBERR1
DO LIN
GOTO ERR^DVBHQM3
+13 IF $DATA(DVBOTM)
IF $DATA(DVBNETER)
SET Y=DVBOTM
DO DD
SET T1=" Message out Time => "_Y
DO LIN
+14 IF $DATA(DVBNETER)
SET T1=" IDCU Network Error"
DO LIN
SET T1=" "_DVBNETER
DO LIN
IF $DATA(DVBREQUE)
SET Y=DVBREQUE
DO DD
SET T1=" "_"Request has been retransmitted"_$SELECT($LENGTH(DVBREQUE):" at "_Y,1:"")
DO LIN
GOTO ERR^DVBHQM3
+15 IF $DATA(DVBNETER)
IF '$DATA(DVBREQUE)
SET T1=" Request NOT retransmitted"
DO LIN
GOTO ERR^DVBHQM3
+16 if X(1)["HINQ"
SET X(1)=$EXTRACT(X(1),1,6)
if $DATA(X(2))
SET X(2)=$EXTRACT(X(2),1,6)
+17 ;
+18 if $DATA(DVBABREV)
GOTO EN^DVBHQM4
+19 GOTO EN^DVBHQM1
+20 ;
DPT SET (S,C,T9)=""
+1 SET T1=$PIECE(^DPT(DFN,0),U)
SET Y=$PIECE(^(0),U,3)
SET T9=$PIECE(^(0),U,9)
DO DD
SET T1=T1_" "_Y_" SSN:"_T9
if $DATA(^(.31))
SET C=$PIECE(^(.31),U,3)
if $DATA(^(.32))
SET S=$PIECE(^(.32),U,8)
SET T1=T1_$SELECT($LENGTH(C):" C-#:"_C,1:"")_$SELECT($LENGTH(S):" S-#:"_S,1:"")_$SELECT($DATA(DVBDIV):" Div:"_DVBDIV,1:"")
QUIT
+2 ;
WARN ;don't compare multiple values for abrev return
if $DATA(DVBABREV)
QUIT
+1 IF $LENGTH(T9)
IF $DATA(DVBSSN)
IF DVBSSN?9N
IF +DVBSSN'=+T9
SET T1="*** SSN from patient file does not match SSN from VBA ***"
DO LIN
+2 IF $LENGTH(C)
IF $DATA(DVBCN)
IF +DVBCN'=+C
SET T1="*** C-# from patient file does not match C-# from VBA ***"
DO LIN
+3 IF $LENGTH(S)
IF $DATA(DVBSN)>9
SET S1=1
FOR N=0:0
SET N=$ORDER(DVBSN(N))
if 'N
QUIT
IF +DVBSN(N)=+S
KILL S1
QUIT
+4 IF $DATA(S1)
SET T1="*** S-# from Patient file does not match a S-# from VBA ***"
DO LIN
+5 QUIT
+6 ;
SEGM if '$DATA(DVBBAS(2))
QUIT
+1 IF '$PIECE(DVBBAS(2),U,35)
IF '$PIECE(DVBBAS(2),U,36)
IF '$PIECE(DVBBAS(2),U,37)
IF '$PIECE(DVBBAS(2),U,38)
QUIT
+2 SET T1=" WARNING: Error Indicators for "
FOR N=38:-1:35
IF $PIECE(DVBBAS(2),U,N)
SET T1=T1_" "_$SELECT(N=38:"BASIC",N=37:"STATISTICAL",N=36:"DIAGNOSTIC",N=35:"FUTURE",1:"")_","
+3 SET T1=$EXTRACT(T1,1,$LENGTH(T1)-1)
DO LIN
+4 QUIT
+5 ;
DATA SET F1=$FIND(Y,"NM")
SET F2=$FIND(Y,"/",F1)
SET F3=$FIND(Y,"SS",F2)
SET F4=$FIND(Y,"CN",F2)
SET F5=$FIND(Y,"SN",F2)
SET T1=" Data Requested:"_$SELECT(F1:" "_$EXTRACT(Y,3,F2-2),1:"")_$SELECT(F3:" SS# "_$EXTRACT(Y,F3,F3+8),1:"")_$SELECT(F4:" C# "_$EXTRACT(Y,F4,F4+8),1:"")_$SELECT(F5:" S# "_$EXTRACT(Y,F5,F5+8),1:"")
QUIT
ERR1 ;set inquiry info into error text
+1 NEW DVBZZ,DVBZZZ
+2 SET DVBZZZ=""
+3 SET DVBZZ=$SELECT($GET(DVBZ)]"":DVBZ,$GET(DVBZ0)]"":DVBZ0,$GET(DVBZ1)]"":DVBZ1,1:"")
+4 ;DVB*4*54 - strip password from string before creating err msg- ERC
+5 IF $GET(DVBZZ)]""
IF $EXTRACT(DVBZZ,$LENGTH(DVBZZ)-3,$LENGTH(DVBZZ))?4U
SET DVBZZ=$EXTRACT(DVBZZ,1,$LENGTH(DVBZZ)-4)
+6 IF DVBZZ["SS"
SET DVBZZZ="SS"_$EXTRACT($PIECE(DVBZZ,"SS",2),1,9)
+7 IF DVBZZ["CN"
SET DVBZZZ=DVBZZZ_" CN"_$EXTRACT($PIECE(DVBZZ,"CN",2),1,9)
+8 IF DVBZZ["SN"
SET DVBZZZ=DVBZZZ_" SN"_$EXTRACT($PIECE(DVBZZ,"SN",2),1,9)
+9 IF $GET(DVBZZZ)]""
SET DVBERR1=DVBZZZ
+10 QUIT
