VistA-WorldVistAEHR/r/SPINAL_CORD_DYSFUNCTION-SPN/SPNFSRV0.m

111 lines
3.5 KiB
Mathematica

SPNFSRV0 ;HISC/DAD-SCD REGISTRY VETERAN SURVEY SERVER ;2/6/96 09:34
;;2.0;Spinal Cord Dysfunction;;01/02/1997
;
D XIT
S SPNFXMZ=XMZ
S SPNFTYPE=$$XMREC,SPNERROR=0
I ";***154^REG;***154.1^FIM;"'[(";"_SPNFTYPE_";") D G EXIT
. S X="Invalid message format, rest of message ignored."
. D ERROR(X)
. Q
K SPNFDATA
S (SPNFREGC,SPNFFIMC,SPNFEXIT,SPNFDATA("E"))=0
F S SPNFDATA=$$XMREC Q:SPNFDATA=""!SPNFEXIT D
. ;
. I SPNFDATA="***^END" D Q
.. S X=$O(SPNFDATA("")) I (X="")!(X="E") Q
.. S SPNFDFN(0)=$P($G(SPNFDATA(0)),U)
.. S SPNFDFN=$$FINDDFN(SPNFDFN(0))
.. I SPNFDFN'>0 D Q
... S SPNFNAME=$P(SPNFDFN(0),";"),SPNFSEX=$P(SPNFDFN(0),";",2)
... S SPNFDOB=$P(SPNFDFN(0),";",3),SPNFSSN=$P(SPNFDFN(0),";",4)
... S SPNFDOB=$E(SPNFDOB,4,5)_"-"_$E(SPNFDOB,6,7)_"-"_$E(SPNFDOB,2,3)
... S SPNFSEX=$S(SPNFSEX="M":"MALE",SPNFSEX="F":"FEMALE",1:"UNKNOWN")
... S X="Patient not found: "_SPNFNAME_" ("_SPNFSEX_") "
... S X=X_SPNFDOB_" "_SPNFSSN_"."
... K SPNFDATA S SPNFDATA("E")=0
... D ERROR(X)
... Q
.. I $P(SPNFTYPE,U,2)="REG" D REG^SPNFSRV1
.. I $P(SPNFTYPE,U,2)="FIM" D FIM^SPNFSRV2
.. K SPNFDATA S SPNFDATA("E")=0
.. Q
. ;
. S SPNFTAG=$P(SPNFDATA,U),SPNFDATA=$P(SPNFDATA,U,2,99)
. S SPNFSUB=$TR(SPNFTAG,"*")
. I (SPNFTAG'?1"*"1E1"*")!("^0^2^5^E^"'[(U_SPNFSUB_U)) D Q
.. S X="Invalid message format, rest of message ignored."
.. D ERROR(X)
.. S SPNFEXIT=1
.. Q
. I SPNFSUB?1N S SPNFDATA(SPNFSUB)=SPNFDATA
. E D
.. S SPNFDATA("E")=SPNFDATA("E")+1
.. S SPNFDATA("E",SPNFDATA("E"))=SPNFDATA
.. Q
. Q
;
EXIT ; *** Send error/info msg, Clean-up, Quit
I SPNERROR'>0 S XMSER="SPNFSURVEY",XMZ=SPNFXMZ D REMSBMSG^XMA1C
D MESSAGE
XIT K D0,D1,DA,DD,DESC,DFN,DIC,DIE,DINUM,DLAYGO,DO,DOB,DPT,DR,DTOUT,IEN
K NAM,SEX,SPND0,SPND1,SPNDATE,SPNDR,SPNERROR,SPNETIOL,SPNFDATA
K SPNFDATE,SPNFDFN,SPNFDOB,SPNFEXIT,SPNFFIMC,SPNFFLDS,SPNFFTYP
K SPNFNAME,SPNFREGC,SPNFSEX,SPNFSSN,SPNFSTAT,SPNFSUB,SPNFTAG,SPNFTYPE
K SPNFXMZ,SPNONSET,SPNOTHER,SPNPIECE,SPNX,SSN,TYPE,X,Y
K ^TMP($J,"SPNERROR")
Q
;
MESSAGE ; *** Send user error/info message
I SPNERROR D
. S X="The SCD Registry Veteran Survey Server has encountered the"
. S ^TMP($J,"SPNERROR",.1)=X
. S X="following problems with MailMan server message # "_SPNFXMZ_":"
. S ^TMP($J,"SPNERROR",.2)=X
. S ^TMP($J,"SPNERROR",.3)=""
. Q
E D
. S X="The SCD Registry Veteran Survey Server has added or modified"
. S ^TMP($J,"SPNERROR",.1)=X
. S X="the following number of records:"
. S ^TMP($J,"SPNERROR",.2)=X
. I $P(SPNFTYPE,U,2)="REG" D
.. S ^TMP($J,"SPNERROR",.3)=" SCD Registry records: "_SPNFREGC
.. Q
. I $P(SPNFTYPE,U,2)="FIM" D
.. S ^TMP($J,"SPNERROR",.3)=" FIM records: "_SPNFFIMC
.. Q
. Q
S XMSUB="SCD Registry Veteran Survey Server"
S XMTEXT="^TMP($J,""SPNERROR"","
S XMY("G.SPNL SCD COORDINATOR")=""
S XMY("G.SPNZ SCD COORDINATOR")=""
D ^XMD
Q
;
FINDDFN(X) ; *** Find a patient DFN
; X = Name ; Sex ; DOB ; SSN ; LAST NAME
N D0,DFN,DOB,DPT,LNM,NAM,SEX,SSN
S NAM=$P(X,";",1),SEX=$P(X,";",2)
S DOB=$P(X,";",3),SSN=$P(X,";",4)
S LNM=$P(X,";",5)
S (D0,DFN)=0
F S D0=$O(^DPT("SSN",SSN,D0)) Q:D0'>0!DFN D
. S DPT=$G(^DPT(D0,0))
. S NAM(0)=$P(DPT,U,1),SEX(0)=$P(DPT,U,2)
. S DOB(0)=$P(DPT,U,3),SSN(0)=$P(DPT,U,9)
. I NAM=NAM(0),SEX=SEX(0),DOB=DOB(0),SSN=SSN(0) S DFN=D0
. I DFN'>0,SSN=SSN(0),LNM=$P(NAM(0),",") S DFN=D0
. Q
Q DFN
;
ERROR(X) ; *** Save error messages
; X = Text of the error msg
S SPNERROR=SPNERROR+1
S ^TMP($J,"SPNERROR",SPNERROR)=X
Q
;
XMREC() ; *** Return next line of message
X XMREC
Q $S(XMER=0:XMRG,1:"")