- 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 Jan 18, 2025@03:18:58 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