ACKQAG05 ;DALC/PJU - UTILITY FOR TRANSMISSION ;02/09/07
;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12,13**;11/01/02;Build 24
;;ALSO CALLED FROM ACKQAG03
; IA# 10103 [Supported] call to FMTE^XLFDT - change date
; IA# 10066 [Supported] call to XMZ^XMA2 - new message stub
; IA# 2701 [Supported] call to GETICN^MPIF001 - get ICN
; IA# 10070 [Supported] call to EN1^XMD - add message text & send
; IA# 2732 [Supported] call to CHKLINES^XMXSEC1 - check message length
; IA# 2240 [Supported] call to ENCRYP^XUSRB1 - encrypt SSN
ACKEXIST() ;returns 1 if 509850.9 exists, else 0
N ACKQANS
I $D(^ACK(509850.9)),$O(^ACK(509850.9,0)) S ACKQANS=1
E S ACKQANS=0
ENDA Q ACKQANS
;
DFNIN(DFN) ;input DFN of patient
;return last entry in 509850.9 for DFN or 0 if none
N ACKQANS,ACKQI,ACKQL
S ACKQANS=0
I $D(^ACK(509850.9,"DFN",DFN)) D
.S ACKQL="A"
.S ACKQL=$O(^ACK(509850.9,"DFN",DFN,ACKQL),-1) Q:'ACKQL ;last date
.S ACKQI=0
.S ACKQI=$O(^ACK(509850.9,"DFN",DFN,ACKQL,ACKQI)) Q:'ACKQI ;entry
.I ACKQI>0 I $G(^ACK(509850.9,ACKQI,0))'="" S ACKQANS=ACKQI
ENDD Q ACKQANS
;
NEWMSG() ;return entry in ^XMB(3.9
; requires DUZ, sets up XMDUZ, XMSUB
;outputs XMZ
S XMSUB="AUDIOGRAM DATA TRANSMISSION",XMDUZ=DUZ
S XMY("S.RMROES3@DDC.DOMAIN.EXT")=""
;S XMY("S.RMROES3@DDCTRN.DOMAIN.EXT")="" ;for testing
D XMZ^XMA2 ;returns XMZ
Q XMZ
;
DFNCT(RESULT,DFN) ;Return number of entries in 509850.9 file
;outputs a number based on the DFN2 xref on DFN only
;Called by RPC ACKQAUD4
N CT,I S (RESULT,CT,I)=0
;G:'$D(^ACK(509850.9,"DFN2",DFN)) ENDC
;F S I=$O(^ACK(509850.9,"DFN2",DFN,I)) Q:'I S CT=CT+1
;S RESULT=CT
S RESULT(0)=CT_U_$P($G(^DPT(DFN,0)),U,1)
F S I=$O(^ACK(509850.9,"DFN2",DFN,I)) Q:'I D
.S CT=CT+1
.S RESULT(CT)=I,$P(RESULT(0),U,1)=CT
ENDC Q RESULT
;
;STARTD(RESULT,DFN,IEN,RMUSER)
STARTD(RESULT,DFN,IEN,ACKQSTNU,ACKQUSNM,ACKQUSSR) ;
;Deletion message for RPC ACKQROESD (DFN & IEN are required)
;N ACKQER,ACKQERR,ACKQFA,ACKQHSSN,ACKQMSG,DFNNAME,SSN,ST
N ACKQER,ACKQERR,ACKQFA,ACKQHSSN,ACKQMSG,ACKQRMI,ACKQVT,SSN,ST,ICN
K ACKQARR S ACKQARR(0)="",ACKQMSG="",XMZ="",ACKQER="",XMMG=""
N XMTEXT,XMDUZ,XMRESTR,XMY,XMSUB
;check for existance and get entry
S ACKQFA=$$ACKEXIST() ;ck if file exist
I 'ACKQFA S ACKQER=$$ERRTEXT(1) G ENDS ;file not exist
I $G(IEN),$D(^ACK(509850.9,IEN,0)) D G ENDS ;local IEN not deleted
.S ACKQER=$$ERRTEXT(10)
S ACKQRMI=IEN ;10/5/05
;create stub and address to S.RMROES3@DDC.DOMAIN.EXT
S (ACKQMSG,XMZ)=$$NEWMSG() ;returns XMZ addressed to S.RMROES3@DDC.DOMAIN.EXT
;get data into array ACKQARR
;ACKQARR(1)=BGN^IEN^DFNNAME^DFNssn^err^bd^tester^Signdt^ex dt^vet^type^age^tt^cl#^retran dt^"D"
S DFNNAME=$P($G(^DPT(DFN,0)),U,1)
S SSN=$P($G(^DPT(DFN,0)),U,9)
S ACKQHSSN=$$ENCRYP^XUSRB1(SSN)
S ACKQARR(1)="BGN^"_ACKQRMI_"^"_DFNNAME_"^"_ACKQHSSN_"^^^^^^^^^^^" ;send encrypted SSN
S ACKQARR(1)=ACKQARR(1)_DT_"^"_"D" ;tran date & delete flag
S X="MPIF001" X ^%ZOSF("TEST")
I S ICN=$$GETICN^MPIF001(DFN),ICN=$E(ICN,1,10)
E S ICN=""
S ACKQARR(2)="DDCINFO"_U_$G(ACKQSTNU)_U_$G(ACKQUSNM)_U_$G(ACKQUSSR)_U
S ACKQARR(2)=ACKQARR(2)_$G(ACKQRMI)_U_$G(ACKQHSSN)_U_U_U_$G(ICN)
S XMTEXT="ACKQARR(",XMDUZ=DUZ,XQDATE=DT,XMSUB="AUIDOGRAM DATA TRANSMISSION"
D CHKLINES^XMXSEC1(XMDUZ,XMZ,.XMRESTR)
I $D(XMRESTR("NONET")) D G ENDS
.S ACKQER="Message too long for network. Limit "_XMRESTR("NONET")
D EN1^XMD ;add text and send
;notify user
S XMSUB="AUDIOGRAM DELETION SENT"
S XMY(DUZ)="",XMDUZ="AUDIOGRAM PKG"
D XMZ^XMA2 ;returns XMZ
K ACKQARR
S ACKQARR(1)="Deletion Message to DALC for "_DFNNAME_" is MSG number:"_ACKQMSG
S ACKQARR(2)="Sent on: "_$$FMTE^XLFDT(DT)
S ACKQARR(3)="AUDIOMETRIC EXAM file entry number: "_ACKQRMI
S XMTEXT="ACKQARR(",XMSUB="AUDIOGRAM DELETION"
D EN1^XMD ;add text and send
ENDS D:$L($G(ACKQER)) WRITEER K ACKQARR,I
;XMMG is the failure msg if there is one
S RESULT=$G(XMZ)_U_$G(ACKQMSG)_U_$G(ACKQER)_U_$G(XMMG)
Q
;
ERRTEXT(ACKQERR) ;error msg's, input error #
N ACKQER1 ;ERROR TEXT
S ACKQER1=$P($T(@(ACKQERR_"^ACKQAG05")),";",3) G ENDE
1 ;;THE AUDIOMETRIC DATA FILE CANNOT BE ACCESSED
2 ;;THERE IS NOT A VALID ENTRY FOR THIS PATIENT
3 ;;THE MESSAGE COULD NOT BE SET UP
4 ;;THE ADDRESS COULD NOT BE SET UP
5 ;;THERE HAS BEEN AN ERROR IN COLLECTING THE AUDIOMETRIC DATA
6 ;;ONE OF THE MESSAGE LINES WAS TOO LONG
7 ;;AN ERROR OCCURRED WHILE PLACING THE DATA INTO THE TRANSMISSION
8 ;;THE ENTRY FOUND IS NOT THE SAME ENTRY THAT IS BEING EDITED
9 ;;THERE IS A CONFLICT BETWEEN THE PATIENT AND THE FILE ENTRY
10 ;;THE RECORD SELECTED HAS NOT BEEN LOCALLY DELETED
ENDE Q ACKQER1
;
WRITEER ;W !!,"*****",ACKQER,"*****" ;for testing
;S:$L($G(XMMG)) ACKQER="MSG FAILURE"
S ACKQER="*****"_ACKQER_"*****"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQAG05 4836 printed Sep 23, 2025@20:07:57 Page 2
ACKQAG05 ;DALC/PJU - UTILITY FOR TRANSMISSION ;02/09/07
+1 ;;3.0;QUASAR AUDIOMETRIC MODULE;**3,12,13**;11/01/02;Build 24
+2 ;;ALSO CALLED FROM ACKQAG03
+3 ; IA# 10103 [Supported] call to FMTE^XLFDT - change date
+4 ; IA# 10066 [Supported] call to XMZ^XMA2 - new message stub
+5 ; IA# 2701 [Supported] call to GETICN^MPIF001 - get ICN
+6 ; IA# 10070 [Supported] call to EN1^XMD - add message text & send
+7 ; IA# 2732 [Supported] call to CHKLINES^XMXSEC1 - check message length
+8 ; IA# 2240 [Supported] call to ENCRYP^XUSRB1 - encrypt SSN
ACKEXIST() ;returns 1 if 509850.9 exists, else 0
+1 NEW ACKQANS
+2 IF $DATA(^ACK(509850.9))
IF $ORDER(^ACK(509850.9,0))
SET ACKQANS=1
+3 IF '$TEST
SET ACKQANS=0
ENDA QUIT ACKQANS
+1 ;
DFNIN(DFN) ;input DFN of patient
+1 ;return last entry in 509850.9 for DFN or 0 if none
+2 NEW ACKQANS,ACKQI,ACKQL
+3 SET ACKQANS=0
+4 IF $DATA(^ACK(509850.9,"DFN",DFN))
Begin DoDot:1
+5 SET ACKQL="A"
+6 ;last date
SET ACKQL=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQL),-1)
if 'ACKQL
QUIT
+7 SET ACKQI=0
+8 ;entry
SET ACKQI=$ORDER(^ACK(509850.9,"DFN",DFN,ACKQL,ACKQI))
if 'ACKQI
QUIT
+9 IF ACKQI>0
IF $GET(^ACK(509850.9,ACKQI,0))'=""
SET ACKQANS=ACKQI
End DoDot:1
ENDD QUIT ACKQANS
+1 ;
NEWMSG() ;return entry in ^XMB(3.9
+1 ; requires DUZ, sets up XMDUZ, XMSUB
+2 ;outputs XMZ
+3 SET XMSUB="AUDIOGRAM DATA TRANSMISSION"
SET XMDUZ=DUZ
+4 SET XMY("S.RMROES3@DDC.DOMAIN.EXT")=""
+5 ;S XMY("S.RMROES3@DDCTRN.DOMAIN.EXT")="" ;for testing
+6 ;returns XMZ
DO XMZ^XMA2
+7 QUIT XMZ
+8 ;
DFNCT(RESULT,DFN) ;Return number of entries in 509850.9 file
+1 ;outputs a number based on the DFN2 xref on DFN only
+2 ;Called by RPC ACKQAUD4
+3 NEW CT,I
SET (RESULT,CT,I)=0
+4 ;G:'$D(^ACK(509850.9,"DFN2",DFN)) ENDC
+5 ;F S I=$O(^ACK(509850.9,"DFN2",DFN,I)) Q:'I S CT=CT+1
+6 ;S RESULT=CT
+7 SET RESULT(0)=CT_U_$PIECE($GET(^DPT(DFN,0)),U,1)
+8 FOR
SET I=$ORDER(^ACK(509850.9,"DFN2",DFN,I))
if 'I
QUIT
Begin DoDot:1
+9 SET CT=CT+1
+10 SET RESULT(CT)=I
SET $PIECE(RESULT(0),U,1)=CT
End DoDot:1
ENDC QUIT RESULT
+1 ;
+2 ;STARTD(RESULT,DFN,IEN,RMUSER)
STARTD(RESULT,DFN,IEN,ACKQSTNU,ACKQUSNM,ACKQUSSR) ;
+1 ;Deletion message for RPC ACKQROESD (DFN & IEN are required)
+2 ;N ACKQER,ACKQERR,ACKQFA,ACKQHSSN,ACKQMSG,DFNNAME,SSN,ST
+3 NEW ACKQER,ACKQERR,ACKQFA,ACKQHSSN,ACKQMSG,ACKQRMI,ACKQVT,SSN,ST,ICN
+4 KILL ACKQARR
SET ACKQARR(0)=""
SET ACKQMSG=""
SET XMZ=""
SET ACKQER=""
SET XMMG=""
+5 NEW XMTEXT,XMDUZ,XMRESTR,XMY,XMSUB
+6 ;check for existance and get entry
+7 ;ck if file exist
SET ACKQFA=$$ACKEXIST()
+8 ;file not exist
IF 'ACKQFA
SET ACKQER=$$ERRTEXT(1)
GOTO ENDS
+9 ;local IEN not deleted
IF $GET(IEN)
IF $DATA(^ACK(509850.9,IEN,0))
Begin DoDot:1
+10 SET ACKQER=$$ERRTEXT(10)
End DoDot:1
GOTO ENDS
+11 ;10/5/05
SET ACKQRMI=IEN
+12 ;create stub and address to S.RMROES3@DDC.DOMAIN.EXT
+13 ;returns XMZ addressed to S.RMROES3@DDC.DOMAIN.EXT
SET (ACKQMSG,XMZ)=$$NEWMSG()
+14 ;get data into array ACKQARR
+15 ;ACKQARR(1)=BGN^IEN^DFNNAME^DFNssn^err^bd^tester^Signdt^ex dt^vet^type^age^tt^cl#^retran dt^"D"
+16 SET DFNNAME=$PIECE($GET(^DPT(DFN,0)),U,1)
+17 SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
+18 SET ACKQHSSN=$$ENCRYP^XUSRB1(SSN)
+19 ;send encrypted SSN
SET ACKQARR(1)="BGN^"_ACKQRMI_"^"_DFNNAME_"^"_ACKQHSSN_"^^^^^^^^^^^"
+20 ;tran date & delete flag
SET ACKQARR(1)=ACKQARR(1)_DT_"^"_"D"
+21 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
+22 IF $TEST
SET ICN=$$GETICN^MPIF001(DFN)
SET ICN=$EXTRACT(ICN,1,10)
+23 IF '$TEST
SET ICN=""
+24 SET ACKQARR(2)="DDCINFO"_U_$GET(ACKQSTNU)_U_$GET(ACKQUSNM)_U_$GET(ACKQUSSR)_U
+25 SET ACKQARR(2)=ACKQARR(2)_$GET(ACKQRMI)_U_$GET(ACKQHSSN)_U_U_U_$GET(ICN)
+26 SET XMTEXT="ACKQARR("
SET XMDUZ=DUZ
SET XQDATE=DT
SET XMSUB="AUIDOGRAM DATA TRANSMISSION"
+27 DO CHKLINES^XMXSEC1(XMDUZ,XMZ,.XMRESTR)
+28 IF $DATA(XMRESTR("NONET"))
Begin DoDot:1
+29 SET ACKQER="Message too long for network. Limit "_XMRESTR("NONET")
End DoDot:1
GOTO ENDS
+30 ;add text and send
DO EN1^XMD
+31 ;notify user
+32 SET XMSUB="AUDIOGRAM DELETION SENT"
+33 SET XMY(DUZ)=""
SET XMDUZ="AUDIOGRAM PKG"
+34 ;returns XMZ
DO XMZ^XMA2
+35 KILL ACKQARR
+36 SET ACKQARR(1)="Deletion Message to DALC for "_DFNNAME_" is MSG number:"_ACKQMSG
+37 SET ACKQARR(2)="Sent on: "_$$FMTE^XLFDT(DT)
+38 SET ACKQARR(3)="AUDIOMETRIC EXAM file entry number: "_ACKQRMI
+39 SET XMTEXT="ACKQARR("
SET XMSUB="AUDIOGRAM DELETION"
+40 ;add text and send
DO EN1^XMD
ENDS if $LENGTH($GET(ACKQER))
DO WRITEER
KILL ACKQARR,I
+1 ;XMMG is the failure msg if there is one
+2 SET RESULT=$GET(XMZ)_U_$GET(ACKQMSG)_U_$GET(ACKQER)_U_$GET(XMMG)
+3 QUIT
+4 ;
ERRTEXT(ACKQERR) ;error msg's, input error #
+1 ;ERROR TEXT
NEW ACKQER1
+2 SET ACKQER1=$PIECE($TEXT(@(ACKQERR_"^ACKQAG05")),";",3)
GOTO ENDE
1 ;;THE AUDIOMETRIC DATA FILE CANNOT BE ACCESSED
2 ;;THERE IS NOT A VALID ENTRY FOR THIS PATIENT
3 ;;THE MESSAGE COULD NOT BE SET UP
4 ;;THE ADDRESS COULD NOT BE SET UP
5 ;;THERE HAS BEEN AN ERROR IN COLLECTING THE AUDIOMETRIC DATA
6 ;;ONE OF THE MESSAGE LINES WAS TOO LONG
7 ;;AN ERROR OCCURRED WHILE PLACING THE DATA INTO THE TRANSMISSION
8 ;;THE ENTRY FOUND IS NOT THE SAME ENTRY THAT IS BEING EDITED
9 ;;THERE IS A CONFLICT BETWEEN THE PATIENT AND THE FILE ENTRY
10 ;;THE RECORD SELECTED HAS NOT BEEN LOCALLY DELETED
ENDE QUIT ACKQER1
+1 ;
WRITEER ;W !!,"*****",ACKQER,"*****" ;for testing
+1 ;S:$L($G(XMMG)) ACKQER="MSG FAILURE"
+2 SET ACKQER="*****"_ACKQER_"*****"
+3 QUIT
