PSJSFRQ ; SMT - SEARCH FOR ERRONEOUS FREQS ; 4/23/09 3:28pm
;;5.0; INPATIENT MEDICATIONS ;**221**; FEB 09;Build 11
; Enter EN^PSJSFRQ for Programmer
; QUE^PSJSFRQ to QUEUE for the past 6 months
; Mail sends to DUZ and anyone holding "PSJ RPHARM" key
Q ; No entry from ^PSJSFRQ
;
QUE ;
N NAMSP,PATCH,JOBN,DTOUT,DUOUT,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,QUIT,Y,ZTQUEUED,ZTREQ,ZTSAVE,PSJQUE,PSRUN
S NAMSP=$$NAMSP
S JOBN="Frequency Report"
S PATCH="PSJ*5*221"
S PSRUN="U" ;This is the type of run UD or IV for the report.
;
L +^XTMP(NAMSP):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I '$T D Q
. D BMES^XPDUTL(JOBN_" job is already running. Halting...")
. D MES^XPDUTL("")
. D QUIT
;
I '$D(^XTMP(NAMSP)) D INITXTMP(NAMSP,JOBN_", "_PATCH,90) ;90 day life
S QUIT=0
;
I $G(^XTMP(NAMSP,0,"LAST"))["COMPLETED" D Q
. W !!,*7,"This job has been run before to completion on "
. W $$FMTE^XLFDT($P($G(^XTMP(NAMSP,0,"LAST")),"^",2)),!!
. W "If you want to run it again, the global subscript ^XTMP('"_NAMSP_"') must be",!
. W "deleted prior to doing so.",!!
. D QUIT
;
;ques 2, if running from mumps prompt
I '$D(XPDQUES("POS2")) D I 'ZTDTH D QUIT Q
. K DIR
. S DIR("A",1)=" Enter when to Queue the "_JOBN_" job to run"
. S DIR("A")=" in date@time format"
. S DIR("B")="NOW"
. S DIR(0)="D^::%DT"
. S DIR("?")=" Enter when to start the job. The default is Now. You can enter a date and time in the format like this: 021506@3:30p"
. D ^DIR I $D(DUOUT) W !,"Halting..." S ZTDTH="" Q
. S:$D(DTOUT) Y=$$NOW^XLFDT S ZTDTH=$$FMTH^XLFDT(Y)
;
;ques 2, if running from kids install
I $D(XPDQUES("POS2")) S ZTDTH=$$FMTH^XLFDT(XPDQUES("POS2"))
;
D BMES^XPDUTL("=============================================================")
D MES^XPDUTL("Queuing background job for "_JOBN_"...")
D MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
D MES^XPDUTL("==============================================================")
I ZTDTH="" D BMES^XPDUTL(JOBN_" NOT QUEUED") D QUIT Q
;
S:$D(^XTMP(NAMSP,0,"LAST")) ^XTMP(NAMSP,0,"ZAUDIT",$H)="RE-STARTED ON"_"^"_$$NOW^XLFDT_"^"_$P(^XTMP(NAMSP,0,"LAST"),"^",2,5)
;
I $P($G(^XTMP(NAMSP,0,"LAST")),"^")="STOP" D
. S $P(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
E D
. S ^XTMP(NAMSP,0,"LAST")="RUN^"_$$NOW^XLFDT_"^^^"
;
S ZTRTN="EN^"_NAMSP,ZTIO="",PSJQUE=1
S ZTDESC="Background job for "_JOBN_" on prescriptions updated via "_PATCH
S ZTSAVE("JOBN")="",ZTSAVE("PSJQUE")="",ZTSAVE("PSRUN")=""
L -^XTMP(NAMSP)
D ^%ZTLOAD
D:$D(ZTSK)
. D MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
. D BMES^XPDUTL("")
D BMES^XPDUTL("")
K XPDQUES
Q
;
EN ;
N MSG,MCNT,START,STOP,I,DFN,IEN,ORD,SCH,OINFO,CNT,I,SUBJ,STARTH,STOPH,VADM,INF,Y,X,% K ERORD
I '$G(PSJQUE) W !,"This report will generate a mailman of problem Orders with incorrect frequency"
I '$G(PSJQUE),'$G(PSRUN) S PSRUN="" F D Q:(PSRUN="U")!(PSRUN="I")!(PSRUN="UI")!(PSRUN="")!(PSRUN["^")
. W !,"Please Select, type of order to run this report on",!,"U - Unit Dose",!,"I - IV",!,"UI - Both",!,"Selection:"
. R PSRUN:$S($G(DTIME):DTIME,1:9999) E S PSRUN="^" Q
. I (PSRUN'="U")&(PSRUN'="I")&(PSRUN'="UI")&(PSRUN'["^")&(PSRUN'="") W " <??>",$C(7)
Q:(PSRUN["^")!(PSRUN="")
D RANGE Q:START=-1
;UD Orders
I PSRUN["U" D
. S I=START F S I=$O(^PS(55,"AUDS",I)) Q:'I!(I>STOP) D
. . S DFN=0 F S DFN=$O(^PS(55,"AUDS",I,DFN)) Q:'DFN D
. . . S IEN=0 F S IEN=$O(^PS(55,"AUDS",I,DFN,IEN)) Q:'IEN D
. . . . S ORD=DFN_";"_IEN_"U"
. . . . K OINFO,SCH S OINFO=$$INFO(ORD) S SCH=$$GETSCH($P(OINFO,"^")) Q:SCH=0
. . . . I $$CHKSDT(ORD) S ERORD(ORD)=""
. . . . I ("AH"[$P(OINFO,"^",4)),+$P(OINFO,"^",3)'=+$P(SCH,"^",3) Q:'$P(OINFO,"^",3)!($P(OINFO,"^",6)'="C") S ERORD(ORD)=""
;IV orders
I PSRUN["I" D
. S I=START F S I=$O(^PS(55,"AIVS",I)) Q:'I!(I>STOP) D
. . S DFN=0 F S DFN=$O(^PS(55,"AIVS",I,DFN)) Q:'DFN D
. . . S IEN=0 F S IEN=$O(^PS(55,"AIVS",I,DFN,IEN)) Q:'IEN D
. . . . S ORD=DFN_";"_IEN_"I"
. . . . K OINFO,SCH S OINFO=$$INFO(ORD) S SCH=$$GETSCH($P(OINFO,"^")) Q:SCH=0
. . . . I ("AH"[$P(OINFO,"^",4)),+$P(OINFO,"^",3)'=+$P(SCH,"^",3) Q:'$P(OINFO,"^",3)!($P(OINFO,"^",6)'="P") S ERORD(ORD)=""
;Pending Orders
;TBD
;
;CREATE Message to send based on ERORD
S CNT=1
S Y=START D DD^%DT S STARTH=Y
S Y=STOP D DD^%DT S STOPH=Y
S SUBJ="FREQUENCY MISMATCH :"_RUNTM
S MSG(CNT)="This is a list of orders with mismatching frequencies and possible",CNT=CNT+1
S MSG(CNT)="start date problems. This excludes orders with no frequency and invalid",CNT=CNT+1
S MSG(CNT)="schedules, the orders on this list need to be reviewed!",CNT=CNT+1
S MSG(CNT)="This report range is from:"_STARTH_" to "_STOPH,CNT=CNT+1
I '$D(ERORD) S MSG(CNT)="There are no problems.",CNT=CNT+1
S I=0 F S I=$O(ERORD(I)) Q:'I D
. S INF=$$INFO(I),DFN=$P(I,";") K VA,VADM D
. . N I D ^VADPT
. S MSG(CNT)="",CNT=CNT+1
. S MSG(CNT)="PATIENT:"_VADM(1)_" SSN:"_VA("BID"),CNT=CNT+1 I I'["I" S MSG(CNT-1)=MSG(CNT-1)_" DRUG:"_$P(^PSDRUG($P(INF,"^",5),0),"^")
. S MSG(CNT)="DFN:"_$P(I,";")_" ORDER#:"_+$P(I,";",2)_" SCHED:"_$P(INF,"^")_" STATUS:"_$P(INF,"^",4),CNT=CNT+1
. S MSG(CNT)=" TYPE:"_$S(I["I":"IV",I["U":"UNIT DOSE",1:"PENDING")_" FREQ:"_$P(INF,"^",3),CNT=CNT+1
;
;Send message
D MAIL(.MSG,SUBJ)
Q
RANGE ;
N NOW,%DT,Y,X,X1,X2,% K START,STOP,RUNTM
D NOW^%DTC S NOW=% S Y=$P(%,".") D DD^%DT S RUNTM=Y
;If this is qued, don't ask, just set to 6 months.
I $G(PSJQUE) S STOP=NOW,X1=NOW,X2=-183 D C^%DTC S START=X Q
S %DT="AEPT",%DT("A")="Start Date:",%DT(0)="-NOW" D ^%DT
S START=Y I Y=-1 Q
S %DT="AEPT",%DT("A")="Stop Date:",%DT(0)=START D ^%DT
S STOP=Y I Y=-1 Q
Q
;
GETSCH(SCHED) ;
;
; Returns "SCHED^AT^FREQ^PKG"
;
N I,FRQ,PKG,AT K FREQ
Q:SCHED']"" 0
I '$O(^PS(51.1,"APPSJ",SCHED,0)) Q 0
S I=0 F S I=$O(^PS(51.1,"APPSJ",SCHED,I)) Q:'I D
. ;Get Data
. S FRQ=$P(^PS(51.1,I,0),"^",3),PKG=$P(^(0),"^",4),AT=$P(^(0),"^",2)
;
Q $G(SCHED)_"^"_$G(AT)_"^"_$G(FRQ)_"^"_$G(PKG)
;
INFO(ORD) ;
;
; IEN=DFN;IEN(TYPE)
; ex 2222;102U or 2222;32I or ;23P
;
; Return "SCHED^AT^FRQ^STATUS^DRUG^SCHTP" (SCHTP is Schedule Type for UD and TYPE for IV
;
N F,SCHED,AT,FRQ,DFN,STAT,DRUG,X,SCHTP,DSPDG,ND0 K DTA55
S DFN=$P(ORD,";")
I ORD["P" S F="^PS(53.1,"_+$P(ORD,";",2)_","
E S F="^PS(55,"_DFN_","_$S(ORD["U":"5",1:"""IV""")_","_+$P(ORD,";",2)_","
;Unit Dose
I (ORD["U")!(ORD["P") D
. S ND0=F_"0)"
. S DSPDG=F_"1," S X=DSPDG_"0)" S X=$O(@X),DSPDG=$G(@(DSPDG_$S(+X:X,1:1)_",0)"))
. S F=F_"2)"
. S SCHED=$P(@F,"^"),AT=$P(@F,"^",5),FRQ=$P(@F,"^",6),STAT=$P(@ND0,"^",9),DRUG=$P(DSPDG,"^"),SCHTP=$P(@ND0,"^",7)
;IV
I ORD["I" D
. S DRUG=""
. S F=F_"0)"
. S SCHED=$P(@F,"^",9),AT=$P(@F,"^",11),FRQ=$P(@F,"^",15),STAT=$P(@F,"^",17),SCHTP=$P(@F,"^",4)
;
Q $G(SCHED)_"^"_$G(AT)_"^"_$G(FRQ)_"^"_$G(STAT)_"^"_$G(DRUG)_"^"_$G(SCHTP)
;
CHKSDT(ORD) ;
;
; If this function returns 1 there is a start date problem.
;
N DFN,ERR,ND2,ND0,I,LIDT,STDT,F,ND
Q:ORD["I" 0
S DFN=$P(ORD,";")
I ORD["P" S F="^PS(53.1,"_+$P(ORD,";",2)_","
E S F="^PS(55,"_DFN_","_$S(ORD["U":"5",1:"""IV""")_","_+$P(ORD,";",2)_","
S ND2=F_"2)",ND2=@ND2,ND0=F_"0)",ND0=@ND0,ERR=0
I ORD["U" D
. S STDT=$P(ND2,"^",2),LIDT=$P(ND0,"^",14),I=""
. F S I=$O(^PS(55,DFN,5,+$P(ORD,";",2),9,I),-1) Q:'I S ND=^(I,0) I $P(ND,"^",3)["Start Date" D Q
. . Q:STDT=LIDT
. . I STDT'=$P(ND,"^",5) S ERR=1
Q ERR
;
MAIL(MSG,SBJ) ; Send out some mail!
N DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,I
S XMDUZ="INPT PHARMACY",XMSUB=SBJ,XMTEXT="MSG("
S XMY(DUZ)="",I=0 F S I=$O(^XUSEC("PSJ RPHARM",I)) Q:'I S XMY(I)=""
D ^XMD
Q ""
;
NAMSP() ;
Q $T(+0)
;
STOP ;stop job command
I $$ST S ^XTMP($$NAMSP,0,"STOP")="" D
. W !,"TALLY MISSING EXPIRATION DATES Job - set to STOP Soon"
. W !!,"Check Status to be sure it has stopped and is not running..."
. W !," (D STATUS^PSOTEXP1)"
Q
;
ST() ;status
L +^XTMP($$NAMSP):3 I $T D Q 0
. L -^XTMP($$NAMSP)
. W !,"*** NOT CURRENTLY RUNNING! ***",!
Q 1
;
INITXTMP(NAMSP,TITLE,LIFE) ;create ^Xtmp according to SAC std
N BEGDT,PURGDT
S BEGDT=$$NOW^XLFDT()
S PURGDT=$$FMADD^XLFDT(BEGDT,LIFE)
S ^XTMP(NAMSP,0)=PURGDT_"^"_BEGDT_"^"_TITLE
Q
;
QUIT ;
L -^XTMP(NAMSP)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJSFRQ 8334 printed Sep 23, 2025@19:45:12 Page 2
PSJSFRQ ; SMT - SEARCH FOR ERRONEOUS FREQS ; 4/23/09 3:28pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**221**; FEB 09;Build 11
+2 ; Enter EN^PSJSFRQ for Programmer
+3 ; QUE^PSJSFRQ to QUEUE for the past 6 months
+4 ; Mail sends to DUZ and anyone holding "PSJ RPHARM" key
+5 ; No entry from ^PSJSFRQ
QUIT
+6 ;
QUE ;
+1 NEW NAMSP,PATCH,JOBN,DTOUT,DUOUT,ZTSK,ZTRTN,ZTIO,ZTDTH,ZTDESC,QUIT,Y,ZTQUEUED,ZTREQ,ZTSAVE,PSJQUE,PSRUN
+2 SET NAMSP=$$NAMSP
+3 SET JOBN="Frequency Report"
+4 SET PATCH="PSJ*5*221"
+5 ;This is the type of run UD or IV for the report.
SET PSRUN="U"
+6 ;
+7 LOCK +^XTMP(NAMSP):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF '$TEST
Begin DoDot:1
+8 DO BMES^XPDUTL(JOBN_" job is already running. Halting...")
+9 DO MES^XPDUTL("")
+10 DO QUIT
End DoDot:1
QUIT
+11 ;
+12 ;90 day life
IF '$DATA(^XTMP(NAMSP))
DO INITXTMP(NAMSP,JOBN_", "_PATCH,90)
+13 SET QUIT=0
+14 ;
+15 IF $GET(^XTMP(NAMSP,0,"LAST"))["COMPLETED"
Begin DoDot:1
+16 WRITE !!,*7,"This job has been run before to completion on "
+17 WRITE $$FMTE^XLFDT($PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^",2)),!!
+18 WRITE "If you want to run it again, the global subscript ^XTMP('"_NAMSP_"') must be",!
+19 WRITE "deleted prior to doing so.",!!
+20 DO QUIT
End DoDot:1
QUIT
+21 ;
+22 ;ques 2, if running from mumps prompt
+23 IF '$DATA(XPDQUES("POS2"))
Begin DoDot:1
+24 KILL DIR
+25 SET DIR("A",1)=" Enter when to Queue the "_JOBN_" job to run"
+26 SET DIR("A")=" in date@time format"
+27 SET DIR("B")="NOW"
+28 SET DIR(0)="D^::%DT"
+29 SET DIR("?")=" Enter when to start the job. The default is Now. You can enter a date and time in the format like this: 021506@3:30p"
+30 DO ^DIR
IF $DATA(DUOUT)
WRITE !,"Halting..."
SET ZTDTH=""
QUIT
+31 if $DATA(DTOUT)
SET Y=$$NOW^XLFDT
SET ZTDTH=$$FMTH^XLFDT(Y)
End DoDot:1
IF 'ZTDTH
DO QUIT
QUIT
+32 ;
+33 ;ques 2, if running from kids install
+34 IF $DATA(XPDQUES("POS2"))
SET ZTDTH=$$FMTH^XLFDT(XPDQUES("POS2"))
+35 ;
+36 DO BMES^XPDUTL("=============================================================")
+37 DO MES^XPDUTL("Queuing background job for "_JOBN_"...")
+38 DO MES^XPDUTL("Start time: "_$$HTE^XLFDT(ZTDTH))
+39 DO MES^XPDUTL("==============================================================")
+40 IF ZTDTH=""
DO BMES^XPDUTL(JOBN_" NOT QUEUED")
DO QUIT
QUIT
+41 ;
+42 if $DATA(^XTMP(NAMSP,0,"LAST"))
SET ^XTMP(NAMSP,0,"ZAUDIT",$HOROLOG)="RE-STARTED ON"_"^"_$$NOW^XLFDT_"^"_$P(^XTMP(NAMSP,0,"LAST"),"^",2,5)
+43 ;
+44 IF $PIECE($GET(^XTMP(NAMSP,0,"LAST")),"^")="STOP"
Begin DoDot:1
+45 SET $PIECE(^XTMP(NAMSP,0,"LAST"),"^",1,2)="RUN^"_$$NOW^XLFDT
End DoDot:1
+46 IF '$TEST
Begin DoDot:1
+47 SET ^XTMP(NAMSP,0,"LAST")="RUN^"_$$NOW^XLFDT_"^^^"
End DoDot:1
+48 ;
+49 SET ZTRTN="EN^"_NAMSP
SET ZTIO=""
SET PSJQUE=1
+50 SET ZTDESC="Background job for "_JOBN_" on prescriptions updated via "_PATCH
+51 SET ZTSAVE("JOBN")=""
SET ZTSAVE("PSJQUE")=""
SET ZTSAVE("PSRUN")=""
+52 LOCK -^XTMP(NAMSP)
+53 DO ^%ZTLOAD
+54 if $DATA(ZTSK)
Begin DoDot:1
+55 DO MES^XPDUTL("*** Task #"_ZTSK_" Queued! ***")
+56 DO BMES^XPDUTL("")
End DoDot:1
+57 DO BMES^XPDUTL("")
+58 KILL XPDQUES
+59 QUIT
+60 ;
EN ;
+1 NEW MSG,MCNT,START,STOP,I,DFN,IEN,ORD,SCH,OINFO,CNT,I,SUBJ,STARTH,STOPH,VADM,INF,Y,X,%
KILL ERORD
+2 IF '$GET(PSJQUE)
WRITE !,"This report will generate a mailman of problem Orders with incorrect frequency"
+3 IF '$GET(PSJQUE)
IF '$GET(PSRUN)
SET PSRUN=""
FOR
Begin DoDot:1
+4 WRITE !,"Please Select, type of order to run this report on",!,"U - Unit Dose",!,"I - IV",!,"UI - Both",!,"Selection:"
+5 READ PSRUN:$SELECT($GET(DTIME):DTIME,1:9999)
IF '$TEST
SET PSRUN="^"
QUIT
+6 IF (PSRUN'="U")&(PSRUN'="I")&(PSRUN'="UI")&(PSRUN'["^")&(PSRUN'="")
WRITE " <??>",$CHAR(7)
End DoDot:1
if (PSRUN="U")!(PSRUN="I")!(PSRUN="UI")!(PSRUN="")!(PSRUN["^")
QUIT
+7 if (PSRUN["^")!(PSRUN="")
QUIT
+8 DO RANGE
if START=-1
QUIT
+9 ;UD Orders
+10 IF PSRUN["U"
Begin DoDot:1
+11 SET I=START
FOR
SET I=$ORDER(^PS(55,"AUDS",I))
if 'I!(I>STOP)
QUIT
Begin DoDot:2
+12 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"AUDS",I,DFN))
if 'DFN
QUIT
Begin DoDot:3
+13 SET IEN=0
FOR
SET IEN=$ORDER(^PS(55,"AUDS",I,DFN,IEN))
if 'IEN
QUIT
Begin DoDot:4
+14 SET ORD=DFN_";"_IEN_"U"
+15 KILL OINFO,SCH
SET OINFO=$$INFO(ORD)
SET SCH=$$GETSCH($PIECE(OINFO,"^"))
if SCH=0
QUIT
+16 IF $$CHKSDT(ORD)
SET ERORD(ORD)=""
+17 IF ("AH"[$PIECE(OINFO,"^",4))
IF +$PIECE(OINFO,"^",3)'=+$PIECE(SCH,"^",3)
if '$PIECE(OINFO,"^",3)!($PIECE(OINFO,"^",6)'="C")
QUIT
SET ERORD(ORD)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;IV orders
+19 IF PSRUN["I"
Begin DoDot:1
+20 SET I=START
FOR
SET I=$ORDER(^PS(55,"AIVS",I))
if 'I!(I>STOP)
QUIT
Begin DoDot:2
+21 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"AIVS",I,DFN))
if 'DFN
QUIT
Begin DoDot:3
+22 SET IEN=0
FOR
SET IEN=$ORDER(^PS(55,"AIVS",I,DFN,IEN))
if 'IEN
QUIT
Begin DoDot:4
+23 SET ORD=DFN_";"_IEN_"I"
+24 KILL OINFO,SCH
SET OINFO=$$INFO(ORD)
SET SCH=$$GETSCH($PIECE(OINFO,"^"))
if SCH=0
QUIT
+25 IF ("AH"[$PIECE(OINFO,"^",4))
IF +$PIECE(OINFO,"^",3)'=+$PIECE(SCH,"^",3)
if '$PIECE(OINFO,"^",3)!($PIECE(OINFO,"^",6)'="P")
QUIT
SET ERORD(ORD)=""
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;Pending Orders
+27 ;TBD
+28 ;
+29 ;CREATE Message to send based on ERORD
+30 SET CNT=1
+31 SET Y=START
DO DD^%DT
SET STARTH=Y
+32 SET Y=STOP
DO DD^%DT
SET STOPH=Y
+33 SET SUBJ="FREQUENCY MISMATCH :"_RUNTM
+34 SET MSG(CNT)="This is a list of orders with mismatching frequencies and possible"
SET CNT=CNT+1
+35 SET MSG(CNT)="start date problems. This excludes orders with no frequency and invalid"
SET CNT=CNT+1
+36 SET MSG(CNT)="schedules, the orders on this list need to be reviewed!"
SET CNT=CNT+1
+37 SET MSG(CNT)="This report range is from:"_STARTH_" to "_STOPH
SET CNT=CNT+1
+38 IF '$DATA(ERORD)
SET MSG(CNT)="There are no problems."
SET CNT=CNT+1
+39 SET I=0
FOR
SET I=$ORDER(ERORD(I))
if 'I
QUIT
Begin DoDot:1
+40 SET INF=$$INFO(I)
SET DFN=$PIECE(I,";")
KILL VA,VADM
Begin DoDot:2
+41 NEW I
DO ^VADPT
End DoDot:2
+42 SET MSG(CNT)=""
SET CNT=CNT+1
+43 SET MSG(CNT)="PATIENT:"_VADM(1)_" SSN:"_VA("BID")
SET CNT=CNT+1
IF I'["I"
SET MSG(CNT-1)=MSG(CNT-1)_" DRUG:"_$PIECE(^PSDRUG($PIECE(INF,"^",5),0),"^")
+44 SET MSG(CNT)="DFN:"_$PIECE(I,";")_" ORDER#:"_+$PIECE(I,";",2)_" SCHED:"_$PIECE(INF,"^")_" STATUS:"_$PIECE(INF,"^",4)
SET CNT=CNT+1
+45 SET MSG(CNT)=" TYPE:"_$SELECT(I["I":"IV",I["U":"UNIT DOSE",1:"PENDING")_" FREQ:"_$PIECE(INF,"^",3)
SET CNT=CNT+1
End DoDot:1
+46 ;
+47 ;Send message
+48 DO MAIL(.MSG,SUBJ)
+49 QUIT
RANGE ;
+1 NEW NOW,%DT,Y,X,X1,X2,%
KILL START,STOP,RUNTM
+2 DO NOW^%DTC
SET NOW=%
SET Y=$PIECE(%,".")
DO DD^%DT
SET RUNTM=Y
+3 ;If this is qued, don't ask, just set to 6 months.
+4 IF $GET(PSJQUE)
SET STOP=NOW
SET X1=NOW
SET X2=-183
DO C^%DTC
SET START=X
QUIT
+5 SET %DT="AEPT"
SET %DT("A")="Start Date:"
SET %DT(0)="-NOW"
DO ^%DT
+6 SET START=Y
IF Y=-1
QUIT
+7 SET %DT="AEPT"
SET %DT("A")="Stop Date:"
SET %DT(0)=START
DO ^%DT
+8 SET STOP=Y
IF Y=-1
QUIT
+9 QUIT
+10 ;
GETSCH(SCHED) ;
+1 ;
+2 ; Returns "SCHED^AT^FREQ^PKG"
+3 ;
+4 NEW I,FRQ,PKG,AT
KILL FREQ
+5 if SCHED']""
QUIT 0
+6 IF '$ORDER(^PS(51.1,"APPSJ",SCHED,0))
QUIT 0
+7 SET I=0
FOR
SET I=$ORDER(^PS(51.1,"APPSJ",SCHED,I))
if 'I
QUIT
Begin DoDot:1
+8 ;Get Data
+9 SET FRQ=$PIECE(^PS(51.1,I,0),"^",3)
SET PKG=$PIECE(^(0),"^",4)
SET AT=$PIECE(^(0),"^",2)
End DoDot:1
+10 ;
+11 QUIT $GET(SCHED)_"^"_$GET(AT)_"^"_$GET(FRQ)_"^"_$GET(PKG)
+12 ;
INFO(ORD) ;
+1 ;
+2 ; IEN=DFN;IEN(TYPE)
+3 ; ex 2222;102U or 2222;32I or ;23P
+4 ;
+5 ; Return "SCHED^AT^FRQ^STATUS^DRUG^SCHTP" (SCHTP is Schedule Type for UD and TYPE for IV
+6 ;
+7 NEW F,SCHED,AT,FRQ,DFN,STAT,DRUG,X,SCHTP,DSPDG,ND0
KILL DTA55
+8 SET DFN=$PIECE(ORD,";")
+9 IF ORD["P"
SET F="^PS(53.1,"_+$PIECE(ORD,";",2)_","
+10 IF '$TEST
SET F="^PS(55,"_DFN_","_$SELECT(ORD["U":"5",1:"""IV""")_","_+$PIECE(ORD,";",2)_","
+11 ;Unit Dose
+12 IF (ORD["U")!(ORD["P")
Begin DoDot:1
+13 SET ND0=F_"0)"
+14 SET DSPDG=F_"1,"
SET X=DSPDG_"0)"
SET X=$ORDER(@X)
SET DSPDG=$GET(@(DSPDG_$SELECT(+X:X,1:1)_",0)"))
+15 SET F=F_"2)"
+16 SET SCHED=$PIECE(@F,"^")
SET AT=$PIECE(@F,"^",5)
SET FRQ=$PIECE(@F,"^",6)
SET STAT=$PIECE(@ND0,"^",9)
SET DRUG=$PIECE(DSPDG,"^")
SET SCHTP=$PIECE(@ND0,"^",7)
End DoDot:1
+17 ;IV
+18 IF ORD["I"
Begin DoDot:1
+19 SET DRUG=""
+20 SET F=F_"0)"
+21 SET SCHED=$PIECE(@F,"^",9)
SET AT=$PIECE(@F,"^",11)
SET FRQ=$PIECE(@F,"^",15)
SET STAT=$PIECE(@F,"^",17)
SET SCHTP=$PIECE(@F,"^",4)
End DoDot:1
+22 ;
+23 QUIT $GET(SCHED)_"^"_$GET(AT)_"^"_$GET(FRQ)_"^"_$GET(STAT)_"^"_$GET(DRUG)_"^"_$GET(SCHTP)
+24 ;
CHKSDT(ORD) ;
+1 ;
+2 ; If this function returns 1 there is a start date problem.
+3 ;
+4 NEW DFN,ERR,ND2,ND0,I,LIDT,STDT,F,ND
+5 if ORD["I"
QUIT 0
+6 SET DFN=$PIECE(ORD,";")
+7 IF ORD["P"
SET F="^PS(53.1,"_+$PIECE(ORD,";",2)_","
+8 IF '$TEST
SET F="^PS(55,"_DFN_","_$SELECT(ORD["U":"5",1:"""IV""")_","_+$PIECE(ORD,";",2)_","
+9 SET ND2=F_"2)"
SET ND2=@ND2
SET ND0=F_"0)"
SET ND0=@ND0
SET ERR=0
+10 IF ORD["U"
Begin DoDot:1
+11 SET STDT=$PIECE(ND2,"^",2)
SET LIDT=$PIECE(ND0,"^",14)
SET I=""
+12 FOR
SET I=$ORDER(^PS(55,DFN,5,+$PIECE(ORD,";",2),9,I),-1)
if 'I
QUIT
SET ND=^(I,0)
IF $PIECE(ND,"^",3)["Start Date"
Begin DoDot:2
+13 if STDT=LIDT
QUIT
+14 IF STDT'=$PIECE(ND,"^",5)
SET ERR=1
End DoDot:2
QUIT
End DoDot:1
+15 QUIT ERR
+16 ;
MAIL(MSG,SBJ) ; Send out some mail!
+1 NEW DIFROM,XMDUZ,XMSUB,XMTEXT,XMY,I
+2 SET XMDUZ="INPT PHARMACY"
SET XMSUB=SBJ
SET XMTEXT="MSG("
+3 SET XMY(DUZ)=""
SET I=0
FOR
SET I=$ORDER(^XUSEC("PSJ RPHARM",I))
if 'I
QUIT
SET XMY(I)=""
+4 DO ^XMD
+5 QUIT ""
+6 ;
NAMSP() ;
+1 QUIT $TEXT(+0)
+2 ;
STOP ;stop job command
+1 IF $$ST
SET ^XTMP($$NAMSP,0,"STOP")=""
Begin DoDot:1
+2 WRITE !,"TALLY MISSING EXPIRATION DATES Job - set to STOP Soon"
+3 WRITE !!,"Check Status to be sure it has stopped and is not running..."
+4 WRITE !," (D STATUS^PSOTEXP1)"
End DoDot:1
+5 QUIT
+6 ;
ST() ;status
+1 LOCK +^XTMP($$NAMSP):3
IF $TEST
Begin DoDot:1
+2 LOCK -^XTMP($$NAMSP)
+3 WRITE !,"*** NOT CURRENTLY RUNNING! ***",!
End DoDot:1
QUIT 0
+4 QUIT 1
+5 ;
INITXTMP(NAMSP,TITLE,LIFE) ;create ^Xtmp according to SAC std
+1 NEW BEGDT,PURGDT
+2 SET BEGDT=$$NOW^XLFDT()
+3 SET PURGDT=$$FMADD^XLFDT(BEGDT,LIFE)
+4 SET ^XTMP(NAMSP,0)=PURGDT_"^"_BEGDT_"^"_TITLE
+5 QUIT
+6 ;
QUIT ;
+1 LOCK -^XTMP(NAMSP)
+2 QUIT
+3 ;
