- PSBMLTS ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;;Mar 2004
- ;
- ; Reference/IA
- ; EN^PSJBCMA/2828
- ; EN^PSJBCMA1/2829
- ; File 50/221
- ;
- EN ;
- N DFN,PSBCNT,PSBDT,PSBERR,PSBMED,PSBNOW,PSBSCHD,PSBVDT
- K ^TMP("PSB",$J),^TMP("PSJ",$J),PSBORD,PSBREC
- W @IOF,!,"Manual Medication Log Trouble Shooter",!!
- S DIC="^DPT(",DIC(0)="AEQM",DIC("A")="Select PATIENT: "
- D ^DIC K DIC Q:+Y<1 S DFN=+Y
- K DIR S DIR(0)="DO^",DIR("A")="Select Date To Validate"
- D ^DIR Q:+Y<1
- S PSBVDT=+Y
- W !,"Searching for Orders..."
- K ^TMP("PSJ",$J)
- D EN^PSJBCMA(DFN,PSBVDT,"")
- Q:$G(^TMP("PSJ",$J,1,0))=-1
- S PSBERR=0
- D NOW^%DTC S PSBNOW=%
- F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:'PSBX D
- .Q:$P(^TMP("PSJ",$J,PSBX,0),U,3)?.N1"P" ; No Pending Yet
- .K PSBORD,^TMP("PSBTMP",$J)
- .M PSBORD=^TMP("PSJ",$J,PSBX)
- .S PSBSCHD=$P(PSBORD(1),U,2)
- .I PSBSCHD="" D Q
- .I PSBSCHD="C"&($P(PSBORD(1),U,6)="") D Q
- ..W !!,"Notice: Order #",+$P(PSBORD(0),U,3)
- ..W $S($P(PSBORD(0),U,3)?.N1"U":" (UNIT DOSE) ",$P(PSBORD(0),U,3)?.N1"V":" (IV) ",1:"")
- ..W " doesn't have administration times"
- .S ^TMP("PSB",$J,PSBSCHD,$P(PSBORD(3),U,2),PSBX)=$P(PSBORD(0),U,3)_U_$P(PSBORD(1),U,6)
- D EN1 G EN
- ;
- EN1 ;
- W $$HDR() I '$D(^TMP("PSB",$J)) W !!?5,"No Med Orders Found!",! Q
- S PSBSCHD="",PSBCNT=0
- F S PSBSCHD=$O(^TMP("PSB",$J,PSBSCHD)) Q:PSBSCHD="" D
- .W ! ; Line between order types
- .S PSBMED=""
- .F S PSBMED=$O(^TMP("PSB",$J,PSBSCHD,PSBMED)) Q:PSBMED="" D
- ..F PSBX=0:0 S PSBX=$O(^TMP("PSB",$J,PSBSCHD,PSBMED,PSBX)) Q:'PSBX D
- ...I $Y>(IOSL-6) W ! K DIR S DIR(0)="E" D ^DIR W:Y $$HDR() I 'Y S PSBSCHD="Z" Q
- ...S PSBCNT=PSBCNT+1
- ...W !,$J(PSBCNT,2),". ",PSBSCHD,?8,PSBMED
- ...W ?40,$P(^TMP("PSB",$J,PSBSCHD,PSBMED,PSBX),U,1),?50,$P(^(PSBX),U,2)
- ...S ^TMP("PSBTMP",$J,PSBCNT)=$P(^TMP("PSB",$J,PSBSCHD,PSBMED,PSBX),U,1)
- F Q:$Y>(IOSL-5) W !
- K DIR S DIR(0)="NO^1:"_PSBCNT_":0" D ^DIR
- I Y S Y=^TMP("PSBTMP",$J,Y) D NEW(Y) K ^TMP("PSBTMP",$J) G EN1
- Q
- ;
- NEW(Y) ; Create the new entry
- N PSBREC
- K ^TMP("PSJ",$J),RESULTS
- W @IOF D EN^PSJBCMA1(DFN,Y)
- K PSBORD M PSBORD=^TMP("PSJ",$J)
- W !,"Order: ",$P(PSBORD(0),U,3)
- W !,"Medication: ",$P(PSBORD(2),U,2)
- W !,"Dosage: ",$P(PSBORD(2),U,3)
- W !,"Schedule: ",$P(PSBORD(4),U,2)
- W !,"Admin Times: ",$P(PSBORD(4),U,9)
- W !,"Start D/T: "
- W !,"Stop D/T: "
- W !!,"Is this the correct Order" S %=1 D YN^DICN Q:%'=1
- ;
- ; PRN, One-Time, On Call orders
- ;
- I $P(PSBORD(4),U,1)'="C" D
- .W ! S %DT="AEQR",%DT("A")="Enter the DATE/TIME of Administration: "
- .S %DT("B")="Now" D ^%DT Q:Y<1 S PSBDT=Y D D^DIQ
- .D FILE
- ;
- ; Continuous Meds
- ;
- I $P(PSBORD(4),U,1)="C" D
- .W ! S %DT="AEQ",%DT("A")="Enter the DATE of Administration: "
- .S %DT("B")="Today" D ^%DT Q:Y<1 S PSBDT=Y D D^DIQ
- .S X="",Y=$P(PSBORD(4),U,9)
- .F Z=1:1:$L(Y,"-") D
- ..S X=X_$S(X]"":";",1:"")_Z_":"_$P(Y,"-",Z)
- .K DIR S DIR(0)="S^"_X,DIR("A")="Select Administration Time"
- .D ^DIR Q:Y<1
- .S PSBDT=+(PSBDT_"."_Y(0))
- .S Y=PSBDT D D^DIQ
- .D FILE
- Q
- ;
- FILE ; Call the med log RPC to validate and order
- I $D(^PSB(53.79,"AORD",DFN,$P(PSBORD(0),U,3),PSBDT)) W !,"-1^Medication is already logged!"
- E D VAL^PSBMLVAL(.RESULTS,DFN,+$P(PSBORD(0),U,3),$E($P(PSBORD(0),U,3),$L($P(PSBORD(0),U,3))),PSBDT) S X="" F S X=$O(RESULTS(X)) Q:X="" W !,RESULTS(X)
- K DIR S DIR(0)="E" D ^DIR
- Q
- ;
- HDR() ;
- W @IOF,"Medication Log Trouble Shooter",!," # "
- W !,$TR($J("",IOM)," ","-")
- Q ""
- ;
- SCANNER ; This checks the scanning mechanism
- N PSBVAL,PSBSCAN,PSBX,PSBFLD
- W ! K DIR
- S DIR(0)="FO^1:45",DIR("A")="Scan Medication" D ^DIR Q:Y["^"!(Y="")
- S PSBVAL=X K DIR
- W !!,"Performing 'Exact Matches' scan of Drug File..."
- K PSBSCAN D SMED(.PSBSCAN,X)
- W !!,"Results of Scan:"
- W $S(+PSBSCAN(0)>0:" Good",1:" Invalid")," scan value."
- S X="" F S X=$O(PSBSCAN(X)) Q:X="" W !!?5,PSBSCAN(X)
- G:+PSBSCAN(0)>0 SCANNER
- W !!,"Performing 'Non-Exact Match' scan on the Drug File...",!
- K ^TMP("DILIST",$J)
- ;
- D FIND^DIC(50,"","","AX",PSBVAL,"*","B^C")
- ;
- I +$G(^TMP("DILIST",$J,0))<1 W !!,"Nothing found in drug file matching '",PSBVAL,"'." G SCANNER
- W !,"There are ",+^TMP("DILIST",$J,0)," matches to '",PSBVAL,"'."
- F PSBX=0:0 S PSBX=$O(^TMP("DILIST",$J,2,PSBX)) Q:'PSBX D
- .W !!,"MATCH #:..................",PSBX
- .W !,"IEN:......................",^TMP("DILIST",$J,2,PSBX)
- .W !,"NAME:.....................",^TMP("DILIST",$J,1,PSBX)
- .S PSBFLD=0
- .F S PSBFLD=$O(^TMP("DILIST",$J,"ID",PSBX,PSBFLD)) Q:'PSBFLD D
- ..D FIELD^DID(50,PSBFLD,"","LABEL","PSBFLD")
- ..W !,PSBFLD("LABEL"),":" F Q:$X>25 W "."
- ..W ^TMP("DILIST",$J,"ID",PSBX,PSBFLD)
- K ^TMP("DILIST",$J)
- Q
- ;
- SMED(RESULTS,PSBDATA) ; Lookup Medication
- I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBDATA?1"3"15N!(PSBDATA?1"3"17N),123[$E(PSBDATA,12) S PSBDATA=$E(PSBDATA,2,11)
- S X=$$FIND1^DIC(50,"","AX",PSBDATA,"B^C")
- I X<1 S RESULTS(0)="-1^Invalid Medication Lookup"
- E S RESULTS(0)=X_U_$$GET1^DIQ(50,X_",",.01)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBMLTS 5031 printed Feb 18, 2025@23:06:37 Page 2
- PSBMLTS ;BIRMINGHAM/EFC-BCMA MEDICATION LOG FUNCTIONS ;Mar 2004
- +1 ;;3.0;BAR CODE MED ADMIN;;Mar 2004
- +2 ;
- +3 ; Reference/IA
- +4 ; EN^PSJBCMA/2828
- +5 ; EN^PSJBCMA1/2829
- +6 ; File 50/221
- +7 ;
- EN ;
- +1 NEW DFN,PSBCNT,PSBDT,PSBERR,PSBMED,PSBNOW,PSBSCHD,PSBVDT
- +2 KILL ^TMP("PSB",$JOB),^TMP("PSJ",$JOB),PSBORD,PSBREC
- +3 WRITE @IOF,!,"Manual Medication Log Trouble Shooter",!!
- +4 SET DIC="^DPT("
- SET DIC(0)="AEQM"
- SET DIC("A")="Select PATIENT: "
- +5 DO ^DIC
- KILL DIC
- if +Y<1
- QUIT
- SET DFN=+Y
- +6 KILL DIR
- SET DIR(0)="DO^"
- SET DIR("A")="Select Date To Validate"
- +7 DO ^DIR
- if +Y<1
- QUIT
- +8 SET PSBVDT=+Y
- +9 WRITE !,"Searching for Orders..."
- +10 KILL ^TMP("PSJ",$JOB)
- +11 DO EN^PSJBCMA(DFN,PSBVDT,"")
- +12 if $GET(^TMP("PSJ",$JOB,1,0))=-1
- QUIT
- +13 SET PSBERR=0
- +14 DO NOW^%DTC
- SET PSBNOW=%
- +15 FOR PSBX=0:0
- SET PSBX=$ORDER(^TMP("PSJ",$JOB,PSBX))
- if 'PSBX
- QUIT
- Begin DoDot:1
- +16 ; No Pending Yet
- if $PIECE(^TMP("PSJ",$JOB,PSBX,0),U,3)?.N1"P"
- QUIT
- +17 KILL PSBORD,^TMP("PSBTMP",$JOB)
- +18 MERGE PSBORD=^TMP("PSJ",$JOB,PSBX)
- +19 SET PSBSCHD=$PIECE(PSBORD(1),U,2)
- +20 IF PSBSCHD=""
- Begin DoDot:2
- End DoDot:2
- QUIT
- +21 IF PSBSCHD="C"&($PIECE(PSBORD(1),U,6)="")
- Begin DoDot:2
- +22 WRITE !!,"Notice: Order #",+$PIECE(PSBORD(0),U,3)
- +23 WRITE $SELECT($PIECE(PSBORD(0),U,3)?.N1"U":" (UNIT DOSE) ",$PIECE(PSBORD(0),U,3)?.N1"V":" (IV) ",1:"")
- +24 WRITE " doesn't have administration times"
- End DoDot:2
- QUIT
- +25 SET ^TMP("PSB",$JOB,PSBSCHD,$PIECE(PSBORD(3),U,2),PSBX)=$PIECE(PSBORD(0),U,3)_U_$PIECE(PSBORD(1),U,6)
- End DoDot:1
- +26 DO EN1
- GOTO EN
- +27 ;
- EN1 ;
- +1 WRITE $$HDR()
- IF '$DATA(^TMP("PSB",$JOB))
- WRITE !!?5,"No Med Orders Found!",!
- QUIT
- +2 SET PSBSCHD=""
- SET PSBCNT=0
- +3 FOR
- SET PSBSCHD=$ORDER(^TMP("PSB",$JOB,PSBSCHD))
- if PSBSCHD=""
- QUIT
- Begin DoDot:1
- +4 ; Line between order types
- WRITE !
- +5 SET PSBMED=""
- +6 FOR
- SET PSBMED=$ORDER(^TMP("PSB",$JOB,PSBSCHD,PSBMED))
- if PSBMED=""
- QUIT
- Begin DoDot:2
- +7 FOR PSBX=0:0
- SET PSBX=$ORDER(^TMP("PSB",$JOB,PSBSCHD,PSBMED,PSBX))
- if 'PSBX
- QUIT
- Begin DoDot:3
- +8 IF $Y>(IOSL-6)
- WRITE !
- KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- if Y
- WRITE $$HDR()
- IF 'Y
- SET PSBSCHD="Z"
- QUIT
- +9 SET PSBCNT=PSBCNT+1
- +10 WRITE !,$JUSTIFY(PSBCNT,2),". ",PSBSCHD,?8,PSBMED
- +11 WRITE ?40,$PIECE(^TMP("PSB",$JOB,PSBSCHD,PSBMED,PSBX),U,1),?50,$PIECE(^(PSBX),U,2)
- +12 SET ^TMP("PSBTMP",$JOB,PSBCNT)=$PIECE(^TMP("PSB",$JOB,PSBSCHD,PSBMED,PSBX),U,1)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 FOR
- if $Y>(IOSL-5)
- QUIT
- WRITE !
- +14 KILL DIR
- SET DIR(0)="NO^1:"_PSBCNT_":0"
- DO ^DIR
- +15 IF Y
- SET Y=^TMP("PSBTMP",$JOB,Y)
- DO NEW(Y)
- KILL ^TMP("PSBTMP",$JOB)
- GOTO EN1
- +16 QUIT
- +17 ;
- NEW(Y) ; Create the new entry
- +1 NEW PSBREC
- +2 KILL ^TMP("PSJ",$JOB),RESULTS
- +3 WRITE @IOF
- DO EN^PSJBCMA1(DFN,Y)
- +4 KILL PSBORD
- MERGE PSBORD=^TMP("PSJ",$JOB)
- +5 WRITE !,"Order: ",$PIECE(PSBORD(0),U,3)
- +6 WRITE !,"Medication: ",$PIECE(PSBORD(2),U,2)
- +7 WRITE !,"Dosage: ",$PIECE(PSBORD(2),U,3)
- +8 WRITE !,"Schedule: ",$PIECE(PSBORD(4),U,2)
- +9 WRITE !,"Admin Times: ",$PIECE(PSBORD(4),U,9)
- +10 WRITE !,"Start D/T: "
- +11 WRITE !,"Stop D/T: "
- +12 WRITE !!,"Is this the correct Order"
- SET %=1
- DO YN^DICN
- if %'=1
- QUIT
- +13 ;
- +14 ; PRN, One-Time, On Call orders
- +15 ;
- +16 IF $PIECE(PSBORD(4),U,1)'="C"
- Begin DoDot:1
- +17 WRITE !
- SET %DT="AEQR"
- SET %DT("A")="Enter the DATE/TIME of Administration: "
- +18 SET %DT("B")="Now"
- DO ^%DT
- if Y<1
- QUIT
- SET PSBDT=Y
- DO D^DIQ
- +19 DO FILE
- End DoDot:1
- +20 ;
- +21 ; Continuous Meds
- +22 ;
- +23 IF $PIECE(PSBORD(4),U,1)="C"
- Begin DoDot:1
- +24 WRITE !
- SET %DT="AEQ"
- SET %DT("A")="Enter the DATE of Administration: "
- +25 SET %DT("B")="Today"
- DO ^%DT
- if Y<1
- QUIT
- SET PSBDT=Y
- DO D^DIQ
- +26 SET X=""
- SET Y=$PIECE(PSBORD(4),U,9)
- +27 FOR Z=1:1:$LENGTH(Y,"-")
- Begin DoDot:2
- +28 SET X=X_$SELECT(X]"":";",1:"")_Z_":"_$PIECE(Y,"-",Z)
- End DoDot:2
- +29 KILL DIR
- SET DIR(0)="S^"_X
- SET DIR("A")="Select Administration Time"
- +30 DO ^DIR
- if Y<1
- QUIT
- +31 SET PSBDT=+(PSBDT_"."_Y(0))
- +32 SET Y=PSBDT
- DO D^DIQ
- +33 DO FILE
- End DoDot:1
- +34 QUIT
- +35 ;
- FILE ; Call the med log RPC to validate and order
- +1 IF $DATA(^PSB(53.79,"AORD",DFN,$PIECE(PSBORD(0),U,3),PSBDT))
- WRITE !,"-1^Medication is already logged!"
- +2 IF '$TEST
- DO VAL^PSBMLVAL(.RESULTS,DFN,+$PIECE(PSBORD(0),U,3),$EXTRACT($PIECE(PSBORD(0),U,3),$LENGTH($PIECE(PSBORD(0),U,3))),PSBDT)
- SET X=""
- FOR
- SET X=$ORDER(RESULTS(X))
- if X=""
- QUIT
- WRITE !,RESULTS(X)
- +3 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- +4 QUIT
- +5 ;
- HDR() ;
- +1 WRITE @IOF,"Medication Log Trouble Shooter",!," # "
- +2 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +3 QUIT ""
- +4 ;
- SCANNER ; This checks the scanning mechanism
- +1 NEW PSBVAL,PSBSCAN,PSBX,PSBFLD
- +2 WRITE !
- KILL DIR
- +3 SET DIR(0)="FO^1:45"
- SET DIR("A")="Scan Medication"
- DO ^DIR
- if Y["^"!(Y="")
- QUIT
- +4 SET PSBVAL=X
- KILL DIR
- +5 WRITE !!,"Performing 'Exact Matches' scan of Drug File..."
- +6 KILL PSBSCAN
- DO SMED(.PSBSCAN,X)
- +7 WRITE !!,"Results of Scan:"
- +8 WRITE $SELECT(+PSBSCAN(0)>0:" Good",1:" Invalid")," scan value."
- +9 SET X=""
- FOR
- SET X=$ORDER(PSBSCAN(X))
- if X=""
- QUIT
- WRITE !!?5,PSBSCAN(X)
- +10 if +PSBSCAN(0)>0
- GOTO SCANNER
- +11 WRITE !!,"Performing 'Non-Exact Match' scan on the Drug File...",!
- +12 KILL ^TMP("DILIST",$JOB)
- +13 ;
- +14 DO FIND^DIC(50,"","","AX",PSBVAL,"*","B^C")
- +15 ;
- +16 IF +$GET(^TMP("DILIST",$JOB,0))<1
- WRITE !!,"Nothing found in drug file matching '",PSBVAL,"'."
- GOTO SCANNER
- +17 WRITE !,"There are ",+^TMP("DILIST",$JOB,0)," matches to '",PSBVAL,"'."
- +18 FOR PSBX=0:0
- SET PSBX=$ORDER(^TMP("DILIST",$JOB,2,PSBX))
- if 'PSBX
- QUIT
- Begin DoDot:1
- +19 WRITE !!,"MATCH #:..................",PSBX
- +20 WRITE !,"IEN:......................",^TMP("DILIST",$JOB,2,PSBX)
- +21 WRITE !,"NAME:.....................",^TMP("DILIST",$JOB,1,PSBX)
- +22 SET PSBFLD=0
- +23 FOR
- SET PSBFLD=$ORDER(^TMP("DILIST",$JOB,"ID",PSBX,PSBFLD))
- if 'PSBFLD
- QUIT
- Begin DoDot:2
- +24 DO FIELD^DID(50,PSBFLD,"","LABEL","PSBFLD")
- +25 WRITE !,PSBFLD("LABEL"),":"
- FOR
- if $X>25
- QUIT
- WRITE "."
- +26 WRITE ^TMP("DILIST",$JOB,"ID",PSBX,PSBFLD)
- End DoDot:2
- End DoDot:1
- +27 KILL ^TMP("DILIST",$JOB)
- +28 QUIT
- +29 ;
- SMED(RESULTS,PSBDATA) ; Lookup Medication
- +1 IF $$GET^XPAR("DIV","PSB ROBOT RX")
- IF PSBDATA?1"3"15N!(PSBDATA?1"3"17N)
- IF 123[$EXTRACT(PSBDATA,12)
- SET PSBDATA=$EXTRACT(PSBDATA,2,11)
- +2 SET X=$$FIND1^DIC(50,"","AX",PSBDATA,"B^C")
- +3 IF X<1
- SET RESULTS(0)="-1^Invalid Medication Lookup"
- +4 IF '$TEST
- SET RESULTS(0)=X_U_$$GET1^DIQ(50,X_",",.01)
- +5 QUIT