AFJXPNHT ;FO-OAKLAND/GMB-PROC SERVER MSG TO ADD PTS TO DB ;1/26/96 10:09
;;5.1;Network Health Exchange;**1,2,31**;Jan 23, 1996
; Totally rewritten 11/2001. (Previously FJ/CWS.)
; Entry points:
; ENTER - Invoked by server option AFJXNETP
; (Messages are created in ^AFJXPNHA)
ENTER ; Process incoming message
; XQMSG has XMZ, XQSUB has msg subject, & XQSND has msg sender (from)
N XMSER,XMZ
D PROCESS(XQMSG,XQSUB,XQSND)
S XMSER="S.AFJXNETP",XMZ=XQMSG D REMSBMSG^XMA1C
Q
PROCESS(AXMZ,AXSUB,AXFROM) ;
N AXSITE,AX25IEN,AX25REC,AXUPDF,AXUPDN,AXNICK,AXI,AXDOMIEN,AXREC
S DUZ=.5,DUZ(0)="@"
S AXSITE=$S(AXFROM["@":$P($P(AXFROM,"@",2),">"),1:^XMB("NETNAME"))
Q:AXSITE=""
D DOMLKUP(AXSITE,.AXDOMIEN,.AX25IEN) Q:'AX25IEN
S AX25REC=$G(^AFJ(537025,AX25IEN,0))
S AXUPDF=$P(AX25REC,U,6) Q:'AXUPDF ; Accept network file update? 0=no; 1=yes
S AXUPDN=$P(AX25REC,U,8) ; Update network identifier? 0=no; 1=yes
S AXNICK=$S(AXUPDN:$P(AX25REC,U,7),1:"") ; Nickname
S AXI=$S($E(^XMB(3.9,AXMZ,2,1,0),1,1)="@":5,1:.99999999)
F S AXI=$O(^XMB(3.9,AXMZ,2,AXI)) Q:'AXI S AXREC=^(AXI,0) D CHKADDPT
Q
DOMLKUP(AXSITE,AXDOMIEN,AX25IEN) ;
N AXDOMREC
S AX25IEN=0
S AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXSITE,"B^C") Q:'AXDOMIEN
S AX25IEN=$O(^AFJ(537025,"B",AXDOMIEN,0)) Q:'AX25IEN
S AXDOMREC=$G(^DIC(4.2,AXDOMIEN,0))
I AXDOMREC'="",$P(AXDOMREC,U,2)'["C" Q
;N DIK,DA ; Domain is closed, so delete it from the authorized sites
;S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
S AX25IEN=0
Q
CHKADDPT ; ADD/EDIT Patient
N AXSSN,AXDOB,AXNAME,DIC,X,Y,AX10IEN,AX25IEN
Q:AXREC["S.AFJXNETP" ; Why is this here?
S AXSSN=$P(AXREC,U,1),AXDOB=$P(AXREC,U,2),AXNAME=$P(AXREC,U,3)
Q:$G(AXSSN)=""
Q:$E(AXSSN,1,9)'?9N
S X=AXSSN,DIC="^AFJ(537010,",DIC(0)="X"
D ^DIC
S AX10IEN=+Y
I AX10IEN>0 D
. N DIE,DA,DR
. S DIE="^AFJ(537010,",DA=AX10IEN,DR="4////"_DT
. D ^DIE
E D Q:AX10IEN<0
. N DIC,X,Y,DD,DO,DA,DINUM,DLAYGO
. S DIC="^AFJ(537010,",DIC(0)="LX",X=AXSSN,DLAYGO=537010
. S DIC("DR")="1////"_AXDOB_";2////"_AXNAME_";4////"_DT
. D FILE^DICN
. S AX10IEN=+Y
I '$D(^AFJ(537010,AX10IEN,1,"B",AXDOMIEN)) D
. N AXFDA
. S AXFDA(537010.04,"+1,"_AX10IEN_",",.01)=AXDOMIEN
. D UPDATE^DIE("","AXFDA")
Q:AXNICK=""
ADDNICK ; Add network identifier
N AXDFN,AXDOMIEN,AXNWI,AXNWI2,AX25IEN
S AXDFN=$$FIND1^DIC(2,"","X",AXSSN,"SSN") Q:'AXDFN
S (AXNWI,AXNWI2)=$G(^DPT(AXDFN,537025))
S AXDOMIEN=0
F S AXDOMIEN=$O(^AFJ(537010,AX10IEN,1,"B",AXDOMIEN)) Q:'AXDOMIEN D
. S AX25IEN=$O(^AFJ(537025,"B",AXDOMIEN,0)) Q:'AX25IEN
. S AXNICK=$P($G(^AFJ(537025,AX25IEN,0)),U,7) Q:AXNICK=""
. I AXNWI'[AXNICK S AXNWI=AXNWI_AXNICK
I AXNWI'=AXNWI2 S ^DPT(AXDFN,537025)=AXNWI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAFJXPNHT 2720 printed Sep 23, 2025@19:54:12 Page 2
AFJXPNHT ;FO-OAKLAND/GMB-PROC SERVER MSG TO ADD PTS TO DB ;1/26/96 10:09
+1 ;;5.1;Network Health Exchange;**1,2,31**;Jan 23, 1996
+2 ; Totally rewritten 11/2001. (Previously FJ/CWS.)
+3 ; Entry points:
+4 ; ENTER - Invoked by server option AFJXNETP
+5 ; (Messages are created in ^AFJXPNHA)
ENTER ; Process incoming message
+1 ; XQMSG has XMZ, XQSUB has msg subject, & XQSND has msg sender (from)
+2 NEW XMSER,XMZ
+3 DO PROCESS(XQMSG,XQSUB,XQSND)
+4 SET XMSER="S.AFJXNETP"
SET XMZ=XQMSG
DO REMSBMSG^XMA1C
+5 QUIT
PROCESS(AXMZ,AXSUB,AXFROM) ;
+1 NEW AXSITE,AX25IEN,AX25REC,AXUPDF,AXUPDN,AXNICK,AXI,AXDOMIEN,AXREC
+2 SET DUZ=.5
SET DUZ(0)="@"
+3 SET AXSITE=$SELECT(AXFROM["@":$PIECE($PIECE(AXFROM,"@",2),">"),1:^XMB("NETNAME"))
+4 if AXSITE=""
QUIT
+5 DO DOMLKUP(AXSITE,.AXDOMIEN,.AX25IEN)
if 'AX25IEN
QUIT
+6 SET AX25REC=$GET(^AFJ(537025,AX25IEN,0))
+7 ; Accept network file update? 0=no; 1=yes
SET AXUPDF=$PIECE(AX25REC,U,6)
if 'AXUPDF
QUIT
+8 ; Update network identifier? 0=no; 1=yes
SET AXUPDN=$PIECE(AX25REC,U,8)
+9 ; Nickname
SET AXNICK=$SELECT(AXUPDN:$PIECE(AX25REC,U,7),1:"")
+10 SET AXI=$SELECT($EXTRACT(^XMB(3.9,AXMZ,2,1,0),1,1)="@":5,1:.99999999)
+11 FOR
SET AXI=$ORDER(^XMB(3.9,AXMZ,2,AXI))
if 'AXI
QUIT
SET AXREC=^(AXI,0)
DO CHKADDPT
+12 QUIT
DOMLKUP(AXSITE,AXDOMIEN,AX25IEN) ;
+1 NEW AXDOMREC
+2 SET AX25IEN=0
+3 SET AXDOMIEN=$$FIND1^DIC(4.2,"","MX",AXSITE,"B^C")
if 'AXDOMIEN
QUIT
+4 SET AX25IEN=$ORDER(^AFJ(537025,"B",AXDOMIEN,0))
if 'AX25IEN
QUIT
+5 SET AXDOMREC=$GET(^DIC(4.2,AXDOMIEN,0))
+6 IF AXDOMREC'=""
IF $PIECE(AXDOMREC,U,2)'["C"
QUIT
+7 ;N DIK,DA ; Domain is closed, so delete it from the authorized sites
+8 ;S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
+9 SET AX25IEN=0
+10 QUIT
CHKADDPT ; ADD/EDIT Patient
+1 NEW AXSSN,AXDOB,AXNAME,DIC,X,Y,AX10IEN,AX25IEN
+2 ; Why is this here?
if AXREC["S.AFJXNETP"
QUIT
+3 SET AXSSN=$PIECE(AXREC,U,1)
SET AXDOB=$PIECE(AXREC,U,2)
SET AXNAME=$PIECE(AXREC,U,3)
+4 if $GET(AXSSN)=""
QUIT
+5 if $EXTRACT(AXSSN,1,9)'?9N
QUIT
+6 SET X=AXSSN
SET DIC="^AFJ(537010,"
SET DIC(0)="X"
+7 DO ^DIC
+8 SET AX10IEN=+Y
+9 IF AX10IEN>0
Begin DoDot:1
+10 NEW DIE,DA,DR
+11 SET DIE="^AFJ(537010,"
SET DA=AX10IEN
SET DR="4////"_DT
+12 DO ^DIE
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 NEW DIC,X,Y,DD,DO,DA,DINUM,DLAYGO
+15 SET DIC="^AFJ(537010,"
SET DIC(0)="LX"
SET X=AXSSN
SET DLAYGO=537010
+16 SET DIC("DR")="1////"_AXDOB_";2////"_AXNAME_";4////"_DT
+17 DO FILE^DICN
+18 SET AX10IEN=+Y
End DoDot:1
if AX10IEN<0
QUIT
+19 IF '$DATA(^AFJ(537010,AX10IEN,1,"B",AXDOMIEN))
Begin DoDot:1
+20 NEW AXFDA
+21 SET AXFDA(537010.04,"+1,"_AX10IEN_",",.01)=AXDOMIEN
+22 DO UPDATE^DIE("","AXFDA")
End DoDot:1
+23 if AXNICK=""
QUIT
ADDNICK ; Add network identifier
+1 NEW AXDFN,AXDOMIEN,AXNWI,AXNWI2,AX25IEN
+2 SET AXDFN=$$FIND1^DIC(2,"","X",AXSSN,"SSN")
if 'AXDFN
QUIT
+3 SET (AXNWI,AXNWI2)=$GET(^DPT(AXDFN,537025))
+4 SET AXDOMIEN=0
+5 FOR
SET AXDOMIEN=$ORDER(^AFJ(537010,AX10IEN,1,"B",AXDOMIEN))
if 'AXDOMIEN
QUIT
Begin DoDot:1
+6 SET AX25IEN=$ORDER(^AFJ(537025,"B",AXDOMIEN,0))
if 'AX25IEN
QUIT
+7 SET AXNICK=$PIECE($GET(^AFJ(537025,AX25IEN,0)),U,7)
if AXNICK=""
QUIT
+8 IF AXNWI'[AXNICK
SET AXNWI=AXNWI_AXNICK
End DoDot:1
+9 IF AXNWI'=AXNWI2
SET ^DPT(AXDFN,537025)=AXNWI
+10 QUIT
