AFJXPNHA ;FO-OAKLAND/GMB-SEND SERVER MSG TO ADD PTS TO DB ;1/17/96 13:14
;;5.1;Network Health Exchange;**31**;Jan 23, 1996
; Totally rewritten 11/2001. (Previously FJ/CWS/RF/BC.)
; Entry points used:
; ENTER - option AFJXNH ADD PATIENTS
ENTER ;
D PROCESS("NIGHTLY NETWORK PT/ID UPDATE",$$FMADD^XLFDT(DT,-2))
Q
PROCESS(AXSUB,AXCUTOFF,AXHDR,AXMAX,AXALIVE) ; Process data
; AXSUB - Message subject
; AXCUTOFF - Only include patients added after this FM date.
; If zero, then all patients are included.
; AXHDR - Include 5 header lines in the message? 0=no; 1=yes
; AXMAX - Maximum number of lines per message. If zero, no max.
; AXALIVE - Include only living patients? 0=no; 1=yes
N AXTO
S AXCUTOFF=+$G(AXCUTOFF),AXHDR=+$G(AXHDR),AXMAX=+$G(AXMAX),AXALIVE=+$G(AXALIVE)
D GETADDR(.AXTO) Q:'$D(AXTO)
K ^TMP("AFJX",$J)
D SENDPTS
Q
GETADDR(AXTO) ;
N AX25IEN,AX25REC,AXDOMREC
S AX25IEN=0
F S AX25IEN=$O(^AFJ(537025,AX25IEN)) Q:'AX25IEN D
. S AX25REC=$G(^AFJ(537025,AX25IEN,0)) Q:AX25REC=""
. Q:'$P(AX25REC,U,4)
. S AXDOMREC=$G(^DIC(4.2,$P(AX25REC,U),0))
. I $P(AXDOMREC,U,2)["C" D Q
. . ;N DIK,DA ; Domain is closed, so delete it from Authorized Sites
. . ;S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
. S AXTO("S.AFJXNETP@"_$P(AXDOMREC,U,1))=""
Q
SENDPTS ;
N AXLINE,AXSITE,AXNICK,AXDFN,AXREC,AXDATE,AXNAME,AXSSN,AXDOB,AXPART
S AXSITE=^XMB("NETNAME")
S AXLINE=$S(AXHDR:5,1:0)
S AX25IEN=+$O(^AFJ(537025,"B",^XMB("NUM"),0))
S AXNICK=$P($G(^AFJ(537025,AX25IEN,0)),U,7)
I 'AXCUTOFF S AXDFN=0
E D
. N AXDAYS
. S AXDAYS=$$FMDIFF^XLFDT(DT,AXCUTOFF)
. I AXDAYS>10 S AXDFN=0 Q
. S AXDFN=$O(^DPT(":"),-1)-(AXDAYS*500)
. I AXDFN<1 S AXDFN=0
F S AXDFN=$O(^DPT(AXDFN)) Q:'AXDFN D
. I AXALIVE Q:$G(^DPT(AXDFN,.35))
. S AXREC=$G(^DPT(AXDFN,0))
. S AXDATE=$P(AXREC,U,16) I AXDATE<AXCUTOFF Q
. S AXNAME=$P(AXREC,U,1) I $E(AXNAME)'?1U!($E(AXNAME,1,2)="ZZ")!($E(AXNAME,1,3)="EEE") Q ;VHA DIRECTIVE 96-0006
. S AXSSN=$P(AXREC,U,9) I AXSSN["P"!(AXSSN?5"0"4N) Q ;VHA DIRECTIVE 96-0006
. S AXDOB=$P(AXREC,U,3)
. ; The last 3 pieces are not used by ^AFJXPNHT. (So why send them?)
. S AXLINE=AXLINE+1,^TMP("AFJX",$J,AXLINE,0)=AXSSN_U_AXDOB_U_AXNAME_U_AXSITE_U_AXDATE_U_AXNICK
. I AXMAX,AXLINE=AXMAX D
. . D SEND(.AXTO)
. . S AXLINE=$S(AXHDR:5,1:0)
Q:'$D(^TMP("AFJX",$J))
D SEND(.AXTO)
Q
SEND(AXTO) ;
N XMSUB,XMDUZ,XMTEXT,XMY
M XMY=AXTO
S XMDUZ=.5
S XMSUB=AXSUB
I AXMAX D
. S AXPART=$G(AXPART)+1
. S XMSUB=XMSUB_" Part "_AXPART
I AXHDR D HEADER
S XMTEXT="^TMP(""AFJX"",$J,"
D ^XMD
K ^TMP("AFJX",$J)
Q
S ^TMP("AFJX",$J,1,0)=$$REPEAT^XLFSTR("@",60)
S ^TMP("AFJX",$J,2,0)=XMSUB_" AS OF "_$$FMTE^XLFDT($$NOW^XLFDT)
S ^TMP("AFJX",$J,3,0)=$$REPEAT^XLFSTR("@",60)
S ^TMP("AFJX",$J,4,0)=^XMB("NETNAME")_" Patient File DPT(0) "_$G(^DPT(0))
S ^TMP("AFJX",$J,5,0)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAFJXPNHA 2914 printed Apr 09, 2024@21:20:52 Page 2
AFJXPNHA ;FO-OAKLAND/GMB-SEND SERVER MSG TO ADD PTS TO DB ;1/17/96 13:14
+1 ;;5.1;Network Health Exchange;**31**;Jan 23, 1996
+2 ; Totally rewritten 11/2001. (Previously FJ/CWS/RF/BC.)
+3 ; Entry points used:
+4 ; ENTER - option AFJXNH ADD PATIENTS
ENTER ;
+1 DO PROCESS("NIGHTLY NETWORK PT/ID UPDATE",$$FMADD^XLFDT(DT,-2))
+2 QUIT
PROCESS(AXSUB,AXCUTOFF,AXHDR,AXMAX,AXALIVE) ; Process data
+1 ; AXSUB - Message subject
+2 ; AXCUTOFF - Only include patients added after this FM date.
+3 ; If zero, then all patients are included.
+4 ; AXHDR - Include 5 header lines in the message? 0=no; 1=yes
+5 ; AXMAX - Maximum number of lines per message. If zero, no max.
+6 ; AXALIVE - Include only living patients? 0=no; 1=yes
+7 NEW AXTO
+8 SET AXCUTOFF=+$GET(AXCUTOFF)
SET AXHDR=+$GET(AXHDR)
SET AXMAX=+$GET(AXMAX)
SET AXALIVE=+$GET(AXALIVE)
+9 DO GETADDR(.AXTO)
if '$DATA(AXTO)
QUIT
+10 KILL ^TMP("AFJX",$JOB)
+11 DO SENDPTS
+12 QUIT
GETADDR(AXTO) ;
+1 NEW AX25IEN,AX25REC,AXDOMREC
+2 SET AX25IEN=0
+3 FOR
SET AX25IEN=$ORDER(^AFJ(537025,AX25IEN))
if 'AX25IEN
QUIT
Begin DoDot:1
+4 SET AX25REC=$GET(^AFJ(537025,AX25IEN,0))
if AX25REC=""
QUIT
+5 if '$PIECE(AX25REC,U,4)
QUIT
+6 SET AXDOMREC=$GET(^DIC(4.2,$PIECE(AX25REC,U),0))
+7 IF $PIECE(AXDOMREC,U,2)["C"
Begin DoDot:2
+8 ;N DIK,DA ; Domain is closed, so delete it from Authorized Sites
+9 ;S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
End DoDot:2
QUIT
+10 SET AXTO("S.AFJXNETP@"_$PIECE(AXDOMREC,U,1))=""
End DoDot:1
+11 QUIT
SENDPTS ;
+1 NEW AXLINE,AXSITE,AXNICK,AXDFN,AXREC,AXDATE,AXNAME,AXSSN,AXDOB,AXPART
+2 SET AXSITE=^XMB("NETNAME")
+3 SET AXLINE=$SELECT(AXHDR:5,1:0)
+4 SET AX25IEN=+$ORDER(^AFJ(537025,"B",^XMB("NUM"),0))
+5 SET AXNICK=$PIECE($GET(^AFJ(537025,AX25IEN,0)),U,7)
+6 IF 'AXCUTOFF
SET AXDFN=0
+7 IF '$TEST
Begin DoDot:1
+8 NEW AXDAYS
+9 SET AXDAYS=$$FMDIFF^XLFDT(DT,AXCUTOFF)
+10 IF AXDAYS>10
SET AXDFN=0
QUIT
+11 SET AXDFN=$ORDER(^DPT(":"),-1)-(AXDAYS*500)
+12 IF AXDFN<1
SET AXDFN=0
End DoDot:1
+13 FOR
SET AXDFN=$ORDER(^DPT(AXDFN))
if 'AXDFN
QUIT
Begin DoDot:1
+14 IF AXALIVE
if $GET(^DPT(AXDFN,.35))
QUIT
+15 SET AXREC=$GET(^DPT(AXDFN,0))
+16 SET AXDATE=$PIECE(AXREC,U,16)
IF AXDATE<AXCUTOFF
QUIT
+17 ;VHA DIRECTIVE 96-0006
SET AXNAME=$PIECE(AXREC,U,1)
IF $EXTRACT(AXNAME)'?1U!($EXTRACT(AXNAME,1,2)="ZZ")!($EXTRACT(AXNAME,1,3)="EEE")
QUIT
+18 ;VHA DIRECTIVE 96-0006
SET AXSSN=$PIECE(AXREC,U,9)
IF AXSSN["P"!(AXSSN?5"0"4N)
QUIT
+19 SET AXDOB=$PIECE(AXREC,U,3)
+20 ; The last 3 pieces are not used by ^AFJXPNHT. (So why send them?)
+21 SET AXLINE=AXLINE+1
SET ^TMP("AFJX",$JOB,AXLINE,0)=AXSSN_U_AXDOB_U_AXNAME_U_AXSITE_U_AXDATE_U_AXNICK
+22 IF AXMAX
IF AXLINE=AXMAX
Begin DoDot:2
+23 DO SEND(.AXTO)
+24 SET AXLINE=$SELECT(AXHDR:5,1:0)
End DoDot:2
End DoDot:1
+25 if '$DATA(^TMP("AFJX",$JOB))
QUIT
+26 DO SEND(.AXTO)
+27 QUIT
SEND(AXTO) ;
+1 NEW XMSUB,XMDUZ,XMTEXT,XMY
+2 MERGE XMY=AXTO
+3 SET XMDUZ=.5
+4 SET XMSUB=AXSUB
+5 IF AXMAX
Begin DoDot:1
+6 SET AXPART=$GET(AXPART)+1
+7 SET XMSUB=XMSUB_" Part "_AXPART
End DoDot:1
+8 IF AXHDR
DO HEADER
+9 SET XMTEXT="^TMP(""AFJX"",$J,"
+10 DO ^XMD
+11 KILL ^TMP("AFJX",$JOB)
+12 QUIT
+1 SET ^TMP("AFJX",$JOB,1,0)=$$REPEAT^XLFSTR("@",60)
+2 SET ^TMP("AFJX",$JOB,2,0)=XMSUB_" AS OF "_$$FMTE^XLFDT($$NOW^XLFDT)
+3 SET ^TMP("AFJX",$JOB,3,0)=$$REPEAT^XLFSTR("@",60)
+4 SET ^TMP("AFJX",$JOB,4,0)=^XMB("NETNAME")_" Patient File DPT(0) "_$GET(^DPT(0))
+5 SET ^TMP("AFJX",$JOB,5,0)=""
+6 QUIT
