PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 ; 1/12/09 12:07pm
;;4.0;PHARMACY BENEFITS MANAGEMENT;**11,15**;MARCH, 2005;Build 2
;
;DBIA's
;References to file #4 - the INSTITUTION file
; DBIA 10090 for: the STATION field - #99
;
;References to file #120.5 - the GMRV VITAL MEASUREMENT file
; DBIA 1381 for: the DATE/TIME VITALS TAKEN field - #.01
; the VITAL TYPE field #.03
; the RATE field #1.2
; the QUALIFIER field #5
;
;References to file #120.51- the GMRV VITAL TYPE file
; DBIA 1382 for: the NAME field - #.01
;
;References to file #120.52 - the GMRV VITAL QUALIFIER file
; DBIA 4504 for: the QUALIFIER field #.01
;
;References to file #9000010.11 - the V IMMUNIZATION file
; DBIA 4567 for: the EVENT DATE AND TIME field #1202
; the IMMUNIZATION field #.01
;
;References to file #2 - the PATIENT file
; DBIA 10035 for: the SOCIAL SECURITY NUMBER field #.09
; DBIA 3504 for: the TEST PATIENT INDICATOR field #.6
;
;References to file #9999999.14 - the IMMUNIZATION file
; DBIA 2454 for: the NAME field #.01
;
EN ;ENtry POINT - Routine control module
;
N SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM
N MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT
S PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING"
D SETUP
D VITALS
D VITALS2
D IMMUNS
D MAILIT
Q ; ** end of routine control module **
;
SETUP ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT
;
S LINEMAX=$$VAL^PSUTL(4.3,1,8.3) ; ** get maximum line length **
S:LINEMAX=""!(LINEMAX>10000) LINEMAX=10000
;
; SET EXTRACT DATE
S %H=$H
D YMD^%DTC
S $P(^TMP("PSUVI",$J),U,3)=X
;
; GET TIME WINDOW
S SDATE=PSUSDT\1-.0001
S EDATE=PSUEDT\1+.2359
;
; GET FACILITY
S PSUFAC=PSUSNDR
;
; SET VARIABLES
I $G(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1 D ;AUTOJOBED
. S PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13"
. S PSUAUTO=1
S LINECNT=999999
S LINETOT=0
;
Q ; ** end of SETUP **
;
VITALS ; EXTRACT VITAL DATA
;
N PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR
N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT
N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG
N PSULN,PSUTXT
;
S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY"""
;
; ** Loop through date index for valid dates **
S PSUDATE=SDATE
;PSU*4*11 Added null ptr notification.
S PSUTXT(1)="The following IEN(s) have a null pointer in the PATIENT (#2) field of"
S PSUTXT(2)="the GMRV VITAL MEASUREMENT file (#120.5). Please notify your IRM and"
S PSUTXT(3)="submit a remedy ticket for help in evaluating the record."
S PSULN=3
F S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE) D
. S PSUV="" ; ** loop thru vitals for each date **
. F S PSUV=$O(^GMR(120.5,"B",PSUDATE,PSUV)) Q:PSUV="" D
.. Q:$P($D(^GMR(120.5,PSUV,2)),U) ;** quit if vital entered in error **
.. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC
.. S PSUPTPTR=$P(PSUVREC,U,2) ; ** point to PATIENT **
.. I PSUPTPTR="" D Q ; ** quit if no patient pointer **
... S PSULN=PSULN+1
... S PSUTXT(PSULN)=PSUV
.. Q:$G(^DPT(PSUPTPTR,0))="" ; ** quit if no patient record **
.. S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record **
.. S PSUSSN=$P(PSUPTREC,U,9) ; ** get SSN
.. ;PSU*4*15
.. Q:'PSUSSN ; ** Quit if no SSN **
.. Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient **
.. Q:$P(PSUPTREC,U,21)=1
.. Q:$P(PSUVREC,U,3)="" ; ** quit if no pointer **
.. S PSUVPTR=$P(PSUVREC,U,3) ; ** point to VITAL **
.. S PSUVTYPE=$P(^GMRD(120.51,PSUVPTR,0),U) ; ** get VITAL TYPE **
.. Q:PSUVLIST'[PSUVTYPE ; ** screen out invalid vital types **
.. S PSURTYPE="V" ; ** set record type **
.. S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** get ICN **
.. I $P(PSUICN,U)="-1" S PSUICN=""
.. S PSUVRATE=$P(PSUVREC,U,8)
.. S PSUVUNIT="" ; ** set vital unit rate **
.. S:PSUVTYPE="PULSE OXIMETRY" PSUVUNIT="%"
.. S:PSUVTYPE="WEIGHT" PSUVUNIT="LBS"
.. S:PSUVTYPE="HEIGHT" PSUVUNIT="IN"
.. S (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)=""
.. D:$D(^GMR(120.5,PSUV,5,0)) ; ** get qualifiers **
... S (PSUQNUM,PSUQCNT)=0
... F S PSUQNUM=$O(^GMR(120.5,PSUV,5,PSUQNUM)) Q:'+PSUQNUM D
.... S PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0)
.... S PSUQCNT=PSUQCNT+1
.... S QQ="PSUVQ"_PSUQCNT
.... S @QQ=$P(^GMRD(120.52,PSUQPTR,0),U)
.. S Z="$"
.. S PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z
.. S PSUVMSG=$TR(PSUVMSG,"^","'")
.. S PSUVMSG=$TR(PSUVMSG,Z,U)
.. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG
.. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG
;PSU*4*11 Send null ptr notifications to PBM group.
I PSULN>3 D
. S XMTEXT="PSUTXT(",XMY("G.PSU PBM")=""
. S XMSUB="** PBM vitals extract detected null patient pointer(s) **"
. S XMDUZ="Pharmacy Benefits Management Package"
. N DIFROM D ^XMD
Q
; ** end of vital extract **
VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP
;
N VPT,VPTV
S VPT=""
; ** F S VPT=$O(PSUVTMP(VPT)) Q:VPT="" D
F S VPT=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT)) Q:VPT="" D
. S VPTV=""
. ; **F S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV="" D
. F S VPTV=$O(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)) Q:VPTV="" D
.. ; ** S X=PSUVTMP(VPT,VPT ; * LOAD VITAL RECORD
.. S X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)
.. S LINECNT=LINECNT+1
.. S LINETOT=LINETOT+1
.. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
.. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load
.. F J=254:-1 Q:$E(X,J)="^"
.. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,J)
.. S LINECNT=LINECNT+1
.. S LINETOT=LINETOT+1
.. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,J,J+253)
Q
;
IMMUNS ;
N PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR
N PSUIMM,PSUICN,PSURTYPE,PSUIMSG
;
S (PSUMCNT,PSUINUM)=0
F S PSUINUM=$O(^AUPNVIMM(PSUINUM)) Q:'PSUINUM D
. S PSUIDATE=$P($G(^AUPNVIMM(PSUINUM,12)),"U") ; ** get IMM date **
. Q:$P(PSUIDATE,U)="" ; ** quit if date is null **
. Q:PSUIDATE<SDATE!(PSUIDATE>EDATE) ; ** quit if date out of range **
. S PSUIREC=^AUPNVIMM(PSUINUM,0) ; ** get IMM record **
. S PSUPTPTR=$P(PSUIREC,U,2) ; ** pointer to PAT file **
. S PSUPTREC=^DPT(PSUPTPTR,0) ; ** get patient record **
. S PSUSSN=$P(PSUPTREC,U,9)
. Q:$E(PSUSSN,1,5)="00000" ; ** quit if invalid patient **
. I $P(PSUPTREC,U,21)=1 Q
. S PSUIMPTR=$P(PSUIREC,U) ; ** point to IMM file **
. S PSUIMM=$P(^AUTTIMM(PSUIMPTR,0),U) ; ** get IMM name **
. S PSUICN=$$GETICN^MPIF001(PSUPTPTR) ; ** set ICN **
. I $P(PSUICN,U)="-1" S PSUICN=""
. S PSURTYPE="I" ; ** set record type **
. S Z="$"
. S PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z
. S PSUIMSG=$TR(PSUIMSG,"^","'")
. S X=$TR(PSUIMSG,Z,U)
. ; *** load ^XTMP ***
. S LINECNT=LINECNT+1
. S LINETOT=LINETOT+1
. I LINECNT>LINEMAX S MSGCNT=$G(MSGCNT)+1,LINECNT=1
. I $L(X)<254 S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X Q ; load
. F K=254:-1 Q:$E(X,K)="^"
. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$E(X,1,K)
. S LINECNT=LINECNT+1
. S LINETOT=LINETOT+1
. S ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$E(X,K,K+253)
; *** save message count ***
S:$G(MSGCNT) ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT
S ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT
Q ; ** quit IMMUNS **
;
MAILIT ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES
;
D ^PSUVIT2
Q ; ** quit for MAILIT **
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUVIT1 8139 printed Oct 16, 2024@18:29:41 Page 2
PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 ; 1/12/09 12:07pm
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**11,15**;MARCH, 2005;Build 2
+2 ;
+3 ;DBIA's
+4 ;References to file #4 - the INSTITUTION file
+5 ; DBIA 10090 for: the STATION field - #99
+6 ;
+7 ;References to file #120.5 - the GMRV VITAL MEASUREMENT file
+8 ; DBIA 1381 for: the DATE/TIME VITALS TAKEN field - #.01
+9 ; the VITAL TYPE field #.03
+10 ; the RATE field #1.2
+11 ; the QUALIFIER field #5
+12 ;
+13 ;References to file #120.51- the GMRV VITAL TYPE file
+14 ; DBIA 1382 for: the NAME field - #.01
+15 ;
+16 ;References to file #120.52 - the GMRV VITAL QUALIFIER file
+17 ; DBIA 4504 for: the QUALIFIER field #.01
+18 ;
+19 ;References to file #9000010.11 - the V IMMUNIZATION file
+20 ; DBIA 4567 for: the EVENT DATE AND TIME field #1202
+21 ; the IMMUNIZATION field #.01
+22 ;
+23 ;References to file #2 - the PATIENT file
+24 ; DBIA 10035 for: the SOCIAL SECURITY NUMBER field #.09
+25 ; DBIA 3504 for: the TEST PATIENT INDICATOR field #.6
+26 ;
+27 ;References to file #9999999.14 - the IMMUNIZATION file
+28 ; DBIA 2454 for: the NAME field #.01
+29 ;
EN ;ENtry POINT - Routine control module
+1 ;
+2 NEW SDATE,EDATE,PSUFAC,PSUIDATE,PSUQCNT,PSUQNUM
+3 NEW MAXLINE,LINECNT,MSGCNT,I,J,K,Z,LINETOT
+4 SET PSUVTMP(0)="TEMP ARRAY FOR PSUVIT1 PROCESSING"
+5 DO SETUP
+6 DO VITALS
+7 DO VITALS2
+8 DO IMMUNS
+9 DO MAILIT
+10 ; ** end of routine control module **
QUIT
+11 ;
SETUP ; SET UP PARTITION FOR VITALS/IMMUNIZATION EXTRACT
+1 ;
+2 ; ** get maximum line length **
SET LINEMAX=$$VAL^PSUTL(4.3,1,8.3)
+3 if LINEMAX=""!(LINEMAX>10000)
SET LINEMAX=10000
+4 ;
+5 ; SET EXTRACT DATE
+6 SET %H=$HOROLOG
+7 DO YMD^%DTC
+8 SET $PIECE(^TMP("PSUVI",$JOB),U,3)=X
+9 ;
+10 ; GET TIME WINDOW
+11 SET SDATE=PSUSDT\1-.0001
+12 SET EDATE=PSUEDT\1+.2359
+13 ;
+14 ; GET FACILITY
+15 SET PSUFAC=PSUSNDR
+16 ;
+17 ; SET VARIABLES
+18 ;AUTOJOBED
IF $GET(^XTMP("PSU_"_PSUJOB,"PSUPSUFLAG"))=1
Begin DoDot:1
+19 SET PSUOPTS="1,2,3,4,5,6,7,8,9,10,11,12,13"
+20 SET PSUAUTO=1
End DoDot:1
+21 SET LINECNT=999999
+22 SET LINETOT=0
+23 ;
+24 ; ** end of SETUP **
QUIT
+25 ;
VITALS ; EXTRACT VITAL DATA
+1 ;
+2 NEW PSUDATE,PSUV,PSUQ,PSUVREC,PSUPTREC,PSUPTPTR,PSUVPTR,PSUQPTR
+3 NEW PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT
+4 NEW Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG
+5 NEW PSULN,PSUTXT
+6 ;
+7 SET PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY"""
+8 ;
+9 ; ** Loop through date index for valid dates **
+10 SET PSUDATE=SDATE
+11 ;PSU*4*11 Added null ptr notification.
+12 SET PSUTXT(1)="The following IEN(s) have a null pointer in the PATIENT (#2) field of"
+13 SET PSUTXT(2)="the GMRV VITAL MEASUREMENT file (#120.5). Please notify your IRM and"
+14 SET PSUTXT(3)="submit a remedy ticket for help in evaluating the record."
+15 SET PSULN=3
+16 FOR
SET PSUDATE=$ORDER(^GMR(120.5,"B",PSUDATE))
if PSUDATE>EDATE!('PSUDATE)
QUIT
Begin DoDot:1
+17 ; ** loop thru vitals for each date **
SET PSUV=""
+18 FOR
SET PSUV=$ORDER(^GMR(120.5,"B",PSUDATE,PSUV))
if PSUV=""
QUIT
Begin DoDot:2
+19 ;** quit if vital entered in error **
if $PIECE($DATA(^GMR(120.5,PSUV,2)),U)
QUIT
+20 SET PSUVREC=$GET(^GMR(120.5,PSUV,0))
if 'PSUVREC
QUIT
+21 ; ** point to PATIENT **
SET PSUPTPTR=$PIECE(PSUVREC,U,2)
+22 ; ** quit if no patient pointer **
IF PSUPTPTR=""
Begin DoDot:3
+23 SET PSULN=PSULN+1
+24 SET PSUTXT(PSULN)=PSUV
End DoDot:3
QUIT
+25 ; ** quit if no patient record **
if $GET(^DPT(PSUPTPTR,0))=""
QUIT
+26 ; ** get patient record **
SET PSUPTREC=^DPT(PSUPTPTR,0)
+27 ; ** get SSN
SET PSUSSN=$PIECE(PSUPTREC,U,9)
+28 ;PSU*4*15
+29 ; ** Quit if no SSN **
if 'PSUSSN
QUIT
+30 ; ** quit if invalid patient **
if $EXTRACT(PSUSSN,1,5)="00000"
QUIT
+31 if $PIECE(PSUPTREC,U,21)=1
QUIT
+32 ; ** quit if no pointer **
if $PIECE(PSUVREC,U,3)=""
QUIT
+33 ; ** point to VITAL **
SET PSUVPTR=$PIECE(PSUVREC,U,3)
+34 ; ** get VITAL TYPE **
SET PSUVTYPE=$PIECE(^GMRD(120.51,PSUVPTR,0),U)
+35 ; ** screen out invalid vital types **
if PSUVLIST'[PSUVTYPE
QUIT
+36 ; ** set record type **
SET PSURTYPE="V"
+37 ; ** get ICN **
SET PSUICN=$$GETICN^MPIF001(PSUPTPTR)
+38 IF $PIECE(PSUICN,U)="-1"
SET PSUICN=""
+39 SET PSUVRATE=$PIECE(PSUVREC,U,8)
+40 ; ** set vital unit rate **
SET PSUVUNIT=""
+41 if PSUVTYPE="PULSE OXIMETRY"
SET PSUVUNIT="%"
+42 if PSUVTYPE="WEIGHT"
SET PSUVUNIT="LBS"
+43 if PSUVTYPE="HEIGHT"
SET PSUVUNIT="IN"
+44 SET (PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4)=""
+45 ; ** get qualifiers **
if $DATA(^GMR(120.5,PSUV,5,0))
Begin DoDot:3
+46 SET (PSUQNUM,PSUQCNT)=0
+47 FOR
SET PSUQNUM=$ORDER(^GMR(120.5,PSUV,5,PSUQNUM))
if '+PSUQNUM
QUIT
Begin DoDot:4
+48 SET PSUQPTR=^GMR(120.5,PSUV,5,PSUQNUM,0)
+49 SET PSUQCNT=PSUQCNT+1
+50 SET QQ="PSUVQ"_PSUQCNT
+51 SET @QQ=$PIECE(^GMRD(120.52,PSUQPTR,0),U)
End DoDot:4
End DoDot:3
+52 SET Z="$"
+53 SET PSUVMSG=Z_PSUFAC_Z_PSUDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_""_Z_PSUVTYPE_Z_PSUVRATE_Z_PSUVUNIT_Z_PSUVQ1_Z_PSUVQ2_Z_PSUVQ3_Z_PSUVQ4_Z
+54 SET PSUVMSG=$TRANSLATE(PSUVMSG,"^","'")
+55 SET PSUVMSG=$TRANSLATE(PSUVMSG,Z,U)
+56 ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG
+57 SET ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG
End DoDot:2
End DoDot:1
+58 ;PSU*4*11 Send null ptr notifications to PBM group.
+59 IF PSULN>3
Begin DoDot:1
+60 SET XMTEXT="PSUTXT("
SET XMY("G.PSU PBM")=""
+61 SET XMSUB="** PBM vitals extract detected null patient pointer(s) **"
+62 SET XMDUZ="Pharmacy Benefits Management Package"
+63 NEW DIFROM
DO ^XMD
End DoDot:1
+64 QUIT
+65 ; ** end of vital extract **
VITALS2 ; LOAD SORTED ARRAY INTO ^XTMP
+1 ;
+2 NEW VPT,VPTV
+3 SET VPT=""
+4 ; ** F S VPT=$O(PSUVTMP(VPT)) Q:VPT="" D
+5 FOR
SET VPT=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT))
if VPT=""
QUIT
Begin DoDot:1
+6 SET VPTV=""
+7 ; **F S VPTV=$O(PSUVTMP(VPT,VPTV)) Q:VPTV="" D
+8 FOR
SET VPTV=$ORDER(^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV))
if VPTV=""
QUIT
Begin DoDot:2
+9 ; ** S X=PSUVTMP(VPT,VPT ; * LOAD VITAL RECORD
+10 SET X=^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",VPT,VPTV)
+11 SET LINECNT=LINECNT+1
+12 SET LINETOT=LINETOT+1
+13 IF LINECNT>LINEMAX
SET MSGCNT=$GET(MSGCNT)+1
SET LINECNT=1
+14 ; load
IF $LENGTH(X)<254
SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X
QUIT
+15 FOR J=254:-1
if $EXTRACT(X,J)="^"
QUIT
+16 SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$EXTRACT(X,1,J)
+17 SET LINECNT=LINECNT+1
+18 SET LINETOT=LINETOT+1
+19 SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$EXTRACT(X,J,J+253)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
IMMUNS ;
+1 NEW PSUDATE,ICNT,PSUINUM,PSUIREC,PSUPTPTR,PSUPTREC,PSUSSN,PSUIMPTR
+2 NEW PSUIMM,PSUICN,PSURTYPE,PSUIMSG
+3 ;
+4 SET (PSUMCNT,PSUINUM)=0
+5 FOR
SET PSUINUM=$ORDER(^AUPNVIMM(PSUINUM))
if 'PSUINUM
QUIT
Begin DoDot:1
+6 ; ** get IMM date **
SET PSUIDATE=$PIECE($GET(^AUPNVIMM(PSUINUM,12)),"U")
+7 ; ** quit if date is null **
if $PIECE(PSUIDATE,U)=""
QUIT
+8 ; ** quit if date out of range **
if PSUIDATE<SDATE!(PSUIDATE>EDATE)
QUIT
+9 ; ** get IMM record **
SET PSUIREC=^AUPNVIMM(PSUINUM,0)
+10 ; ** pointer to PAT file **
SET PSUPTPTR=$PIECE(PSUIREC,U,2)
+11 ; ** get patient record **
SET PSUPTREC=^DPT(PSUPTPTR,0)
+12 SET PSUSSN=$PIECE(PSUPTREC,U,9)
+13 ; ** quit if invalid patient **
if $EXTRACT(PSUSSN,1,5)="00000"
QUIT
+14 IF $PIECE(PSUPTREC,U,21)=1
QUIT
+15 ; ** point to IMM file **
SET PSUIMPTR=$PIECE(PSUIREC,U)
+16 ; ** get IMM name **
SET PSUIMM=$PIECE(^AUTTIMM(PSUIMPTR,0),U)
+17 ; ** set ICN **
SET PSUICN=$$GETICN^MPIF001(PSUPTPTR)
+18 IF $PIECE(PSUICN,U)="-1"
SET PSUICN=""
+19 ; ** set record type **
SET PSURTYPE="I"
+20 SET Z="$"
+21 SET PSUIMSG=Z_PSUFAC_Z_PSUIDATE_Z_PSURTYPE_Z_PSUSSN_Z_PSUICN_Z_PSUIMM_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z_""_Z
+22 SET PSUIMSG=$TRANSLATE(PSUIMSG,"^","'")
+23 SET X=$TRANSLATE(PSUIMSG,Z,U)
+24 ; *** load ^XTMP ***
+25 SET LINECNT=LINECNT+1
+26 SET LINETOT=LINETOT+1
+27 IF LINECNT>LINEMAX
SET MSGCNT=$GET(MSGCNT)+1
SET LINECNT=1
+28 ; load
IF $LENGTH(X)<254
SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=X
QUIT
+29 FOR K=254:-1
if $EXTRACT(X,K)="^"
QUIT
+30 SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)=$EXTRACT(X,1,K)
+31 SET LINECNT=LINECNT+1
+32 SET LINETOT=LINETOT+1
+33 SET ^XTMP("PSU_"_PSUJOB,"PSUVI",MSGCNT,LINECNT)="*"_$EXTRACT(X,K,K+253)
End DoDot:1
+34 ; *** save message count ***
+35 if $GET(MSGCNT)
SET ^XTMP("PSU_"_PSUJOB,"PSUVI","MSGTCNT")=MSGCNT
+36 SET ^XTMP("PSU_"_PSUJOB,"PSUVI","LINECNT")=LINETOT
+37 ; ** quit IMMUNS **
QUIT
+38 ;
MAILIT ; MAIL VITAL & IMMUNIZATION EXTRACT MESSAGES
+1 ;
+2 DO ^PSUVIT2
+3 ; ** quit for MAILIT **
QUIT
+4 ;
