AFJXWCP1 ;FO-OAKLAND/GMB-REQUEST PATIENT INFORMATION ;4/11/96 05:36
;;5.1;Network Health Exchange;**1,31,34**;Jan 23, 1996
; Totally rewritten 11/2001. (Previously FJ/CWS.)
; Called from ^AFJXWCPM
REQUEST(AXTYPE) ; Request data
N AXFINIS,AXABORT,AXPARM,AXSSN,I
S (AXFINIS,AXABORT)=0
D INIT(AXTYPE,.AXPARM,.AXABORT) Q:AXABORT
W @IOF,!! F I=1:1:80 W "@"
W !,?8,"This option will request ",AXPARM("U")," DATA from another VAMC."
W ! F I=1:1:80 W "@"
W !!,?5,"You can't request information if the patient is not already on file.",!
F D Q:AXFINIS!AXABORT
. N DIC,X,Y,AXTO
. W !!
. S DIC("A")="SOCIAL SECURITY # or NAME: "
. S DIC="^DPT("
. S DIC(0)="AEMOQZ"
. D ^DIC I Y<1 S AXFINIS=1 Q
. S AXSSN=$P(Y(0),U,9)
. I $G(AXSSN)["P" W !,?5,$C(7),"SORRY, You can't request Pseudo SSNs." Q
. D SITES(.AXTO,.AXABORT) Q:AXABORT
. I '$D(AXTO) D Q
. . W !,$C(7),"No valid sites chosen. No request sent."
. D MESSAGE(.AXTO,AXSSN)
Q
INIT(AXTYPE,AXPARM,AXABORT) ;
I AXTYPE="R" S AXPARM("U")="PATIENT PHARMACY",AXPARM("S")="PHARMACY DATA",AXPARM("L")="PHARM"
E I AXTYPE="RB" S AXPARM("U")="BRIEF PHARMACY",AXPARM("S")="BRIEF PHARMACY",AXPARM("L")="NHBP"
E I AXTYPE="P" S AXPARM("U")="PATIENT",AXPARM("S")="TOTAL DATA",AXPARM("L")="TOTAL"
E I AXTYPE="PB" S AXPARM("U")="BRIEF PATIENT",AXPARM("S")="BRIEF DATA",AXPARM("L")="BRIEF"
E D Q
. W !,"Routine ^AFJXWCP1 called with incorrect TYPE parameter: ",AXTYPE
. S AXABORT=1
N DIR,X,Y
W !
S DIR(0)="Y"
S DIR("A")="Would you like to look for any previous requests on file"
S DIR("B")="NO"
D ^DIR I $D(DTOUT)!$D(DUOUT) S AXABORT=1 Q
D:Y ENTER^AFJXMBOX
Q
SITES(AXTO,AXABORT) ; Choose station(s)
N AXFINIS,AXDOMIEN,AX25IEN,DIR,X,Y,DIRUT
S DIR(0)="S^A:ALL Local Area Sites;S:Selected Sites"
S DIR("A")="Request patient information from"
D ^DIR I $D(DIRUT) S AXABORT=1 Q
I Y="A" D CHKALL(.AXTO) Q
K DIR,X,Y
S AXFINIS=0
F D Q:AXFINIS!AXABORT
. N DIC,X,Y,DUOUT,DTOUT
. W !
. S DIC=537025,DIC(0)="AEMOQ"
. S DIC("A")=$S($D(AXTO):"Another site: ",1:"Select a site: ")
. S DIC("S")="I $P($G(^DIC(4.2,+^(0),0)),U,2)'[""C"""
. D ^DIC I $D(DUOUT)!$D(DTOUT) S AXABORT=1 Q
. I Y<1 S AXFINIS=1 Q
. S AXDOMIEN=$P(Y,U,2),AX25IEN=+Y
. D CHKSITE(AXDOMIEN,AX25IEN,.AXTO)
Q
CHKALL(AXTO) ; "ALL LOCAL AREA SITES"
N AX25IEN,AX25REC
W !,"Network Area Recipients:"
S AX25IEN=0
F S AX25IEN=$O(^AFJ(537025,AX25IEN)) Q:'AX25IEN D
. S AX25REC=$G(^AFJ(537025,AX25IEN,0))
. I $P(AX25REC,U,3) D CHKSITE($P(AX25REC,U),AX25IEN,.AXTO)
Q
CHKSITE(AXDOMIEN,AX25IEN,AXTO) ;
N AXBAD,AXDOMREC
S AXBAD=0
I AXDOMIEN=^XMB("NUM") D
. ;S AXBAD=1
. S AXTO("S.AFJXSERVER")=""
. W !,^XMB("NETNAME")," FYI: That's this domain."
. S AXTO("S.AFJXSERVER")=""
E D
. S AXDOMREC=$P(^DIC(4.2,AXDOMIEN,0),U,1,2)
. I AXDOMREC="" D Q
. . S AXBAD=1
. . ;W !!,$C(7),"Broken pointer to the DOMAIN file."
. I $P(AXDOMREC,U,2)'["C" D Q
. . S AXTO("S.AFJXSERVER@"_$P(AXDOMREC,U,1))=""
. . W !,$P(AXDOMREC,U,1)
. S AXBAD=1
. ;W !!,$C(7),"Domain ",DOMNAME," is closed."
Q:'AXBAD
;W !," Ignoring it."
Q
;W !," Deleting it from the Authorized Sites file."
;N DIK,DA S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
;Q
MESSAGE(XMY,AXSSN) ; Build message and transmit
N XMSUB,XMDUZ,XMTEXT,XMZ,AXRQST,AXREC,DIC,DLAYGO,X,Y,DA,DINUM,DD,DO
W !!,"Sending Patient Data Request..."
S XMDUZ=DUZ,XMTEXT="AXRQST("
S XMSUB="NETWORK HEALTH EXCHANGE "_AXPARM("S")_" REQUEST FOR "_AXSSN
S AXRQST(1)=AXSSN_U_DUZ_U_$P($G(^VA(200,+DUZ,0)),U)_U_$$NOW^XLFDT_U_^XMB("NETNAME")_U_AXPARM("L")
D ^XMD W !,"Local Message ID: "_XMZ
; Audit
S AXREC=AXRQST(1)
S DIC="^AFJ(537000,",DLAYGO=537000
S DIC(0)="L",X=XMZ
S DIC("DR")="1////"_$P(AXREC,U,4)_";2////"_AXPARM("L")_";3////"_AXSSN_";6////"_DUZ_";7////"_$P(AXREC,U,3)_";8////"_^XMB("NUM")_";11////Y"
D FILE^DICN
W !!,"Your request has been submitted for completion."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HAFJXWCP1 3969 printed Nov 22, 2024@17:28:03 Page 2
AFJXWCP1 ;FO-OAKLAND/GMB-REQUEST PATIENT INFORMATION ;4/11/96 05:36
+1 ;;5.1;Network Health Exchange;**1,31,34**;Jan 23, 1996
+2 ; Totally rewritten 11/2001. (Previously FJ/CWS.)
+3 ; Called from ^AFJXWCPM
REQUEST(AXTYPE) ; Request data
+1 NEW AXFINIS,AXABORT,AXPARM,AXSSN,I
+2 SET (AXFINIS,AXABORT)=0
+3 DO INIT(AXTYPE,.AXPARM,.AXABORT)
if AXABORT
QUIT
+4 WRITE @IOF,!!
FOR I=1:1:80
WRITE "@"
+5 WRITE !,?8,"This option will request ",AXPARM("U")," DATA from another VAMC."
+6 WRITE !
FOR I=1:1:80
WRITE "@"
+7 WRITE !!,?5,"You can't request information if the patient is not already on file.",!
+8 FOR
Begin DoDot:1
+9 NEW DIC,X,Y,AXTO
+10 WRITE !!
+11 SET DIC("A")="SOCIAL SECURITY # or NAME: "
+12 SET DIC="^DPT("
+13 SET DIC(0)="AEMOQZ"
+14 DO ^DIC
IF Y<1
SET AXFINIS=1
QUIT
+15 SET AXSSN=$PIECE(Y(0),U,9)
+16 IF $GET(AXSSN)["P"
WRITE !,?5,$CHAR(7),"SORRY, You can't request Pseudo SSNs."
QUIT
+17 DO SITES(.AXTO,.AXABORT)
if AXABORT
QUIT
+18 IF '$DATA(AXTO)
Begin DoDot:2
+19 WRITE !,$CHAR(7),"No valid sites chosen. No request sent."
End DoDot:2
QUIT
+20 DO MESSAGE(.AXTO,AXSSN)
End DoDot:1
if AXFINIS!AXABORT
QUIT
+21 QUIT
INIT(AXTYPE,AXPARM,AXABORT) ;
+1 IF AXTYPE="R"
SET AXPARM("U")="PATIENT PHARMACY"
SET AXPARM("S")="PHARMACY DATA"
SET AXPARM("L")="PHARM"
+2 IF '$TEST
IF AXTYPE="RB"
SET AXPARM("U")="BRIEF PHARMACY"
SET AXPARM("S")="BRIEF PHARMACY"
SET AXPARM("L")="NHBP"
+3 IF '$TEST
IF AXTYPE="P"
SET AXPARM("U")="PATIENT"
SET AXPARM("S")="TOTAL DATA"
SET AXPARM("L")="TOTAL"
+4 IF '$TEST
IF AXTYPE="PB"
SET AXPARM("U")="BRIEF PATIENT"
SET AXPARM("S")="BRIEF DATA"
SET AXPARM("L")="BRIEF"
+5 IF '$TEST
Begin DoDot:1
+6 WRITE !,"Routine ^AFJXWCP1 called with incorrect TYPE parameter: ",AXTYPE
+7 SET AXABORT=1
End DoDot:1
QUIT
+8 NEW DIR,X,Y
+9 WRITE !
+10 SET DIR(0)="Y"
+11 SET DIR("A")="Would you like to look for any previous requests on file"
+12 SET DIR("B")="NO"
+13 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET AXABORT=1
QUIT
+14 if Y
DO ENTER^AFJXMBOX
+15 QUIT
SITES(AXTO,AXABORT) ; Choose station(s)
+1 NEW AXFINIS,AXDOMIEN,AX25IEN,DIR,X,Y,DIRUT
+2 SET DIR(0)="S^A:ALL Local Area Sites;S:Selected Sites"
+3 SET DIR("A")="Request patient information from"
+4 DO ^DIR
IF $DATA(DIRUT)
SET AXABORT=1
QUIT
+5 IF Y="A"
DO CHKALL(.AXTO)
QUIT
+6 KILL DIR,X,Y
+7 SET AXFINIS=0
+8 FOR
Begin DoDot:1
+9 NEW DIC,X,Y,DUOUT,DTOUT
+10 WRITE !
+11 SET DIC=537025
SET DIC(0)="AEMOQ"
+12 SET DIC("A")=$SELECT($DATA(AXTO):"Another site: ",1:"Select a site: ")
+13 SET DIC("S")="I $P($G(^DIC(4.2,+^(0),0)),U,2)'[""C"""
+14 DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)
SET AXABORT=1
QUIT
+15 IF Y<1
SET AXFINIS=1
QUIT
+16 SET AXDOMIEN=$PIECE(Y,U,2)
SET AX25IEN=+Y
+17 DO CHKSITE(AXDOMIEN,AX25IEN,.AXTO)
End DoDot:1
if AXFINIS!AXABORT
QUIT
+18 QUIT
CHKALL(AXTO) ; "ALL LOCAL AREA SITES"
+1 NEW AX25IEN,AX25REC
+2 WRITE !,"Network Area Recipients:"
+3 SET AX25IEN=0
+4 FOR
SET AX25IEN=$ORDER(^AFJ(537025,AX25IEN))
if 'AX25IEN
QUIT
Begin DoDot:1
+5 SET AX25REC=$GET(^AFJ(537025,AX25IEN,0))
+6 IF $PIECE(AX25REC,U,3)
DO CHKSITE($PIECE(AX25REC,U),AX25IEN,.AXTO)
End DoDot:1
+7 QUIT
CHKSITE(AXDOMIEN,AX25IEN,AXTO) ;
+1 NEW AXBAD,AXDOMREC
+2 SET AXBAD=0
+3 IF AXDOMIEN=^XMB("NUM")
Begin DoDot:1
+4 ;S AXBAD=1
+5 SET AXTO("S.AFJXSERVER")=""
+6 WRITE !,^XMB("NETNAME")," FYI: That's this domain."
+7 SET AXTO("S.AFJXSERVER")=""
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 SET AXDOMREC=$PIECE(^DIC(4.2,AXDOMIEN,0),U,1,2)
+10 IF AXDOMREC=""
Begin DoDot:2
+11 SET AXBAD=1
+12 ;W !!,$C(7),"Broken pointer to the DOMAIN file."
End DoDot:2
QUIT
+13 IF $PIECE(AXDOMREC,U,2)'["C"
Begin DoDot:2
+14 SET AXTO("S.AFJXSERVER@"_$PIECE(AXDOMREC,U,1))=""
+15 WRITE !,$PIECE(AXDOMREC,U,1)
End DoDot:2
QUIT
+16 SET AXBAD=1
+17 ;W !!,$C(7),"Domain ",DOMNAME," is closed."
End DoDot:1
+18 if 'AXBAD
QUIT
+19 ;W !," Ignoring it."
+20 QUIT
+21 ;W !," Deleting it from the Authorized Sites file."
+22 ;N DIK,DA S DIK="^AFJ(537025,",DA=AX25IEN D ^DIK
+23 ;Q
MESSAGE(XMY,AXSSN) ; Build message and transmit
+1 NEW XMSUB,XMDUZ,XMTEXT,XMZ,AXRQST,AXREC,DIC,DLAYGO,X,Y,DA,DINUM,DD,DO
+2 WRITE !!,"Sending Patient Data Request..."
+3 SET XMDUZ=DUZ
SET XMTEXT="AXRQST("
+4 SET XMSUB="NETWORK HEALTH EXCHANGE "_AXPARM("S")_" REQUEST FOR "_AXSSN
+5 SET AXRQST(1)=AXSSN_U_DUZ_U_$PIECE($GET(^VA(200,+DUZ,0)),U)_U_$$NOW^XLFDT_U_^XMB("NETNAME")_U_AXPARM("L")
+6 DO ^XMD
WRITE !,"Local Message ID: "_XMZ
+7 ; Audit
+8 SET AXREC=AXRQST(1)
+9 SET DIC="^AFJ(537000,"
SET DLAYGO=537000
+10 SET DIC(0)="L"
SET X=XMZ
+11 SET DIC("DR")="1////"_$PIECE(AXREC,U,4)_";2////"_AXPARM("L")_";3////"_AXSSN_";6////"_DUZ_";7////"_$PIECE(AXREC,U,3)_";8////"_^XMB("NUM")_";11////Y"
+12 DO FILE^DICN
+13 WRITE !!,"Your request has been submitted for completion."
+14 QUIT
