Routine: ORY117

ORY117 ;SLC/MKB -- post-install for OR*3*117;02:56 PM  8 May 2001

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**117**;Dec 17, 1997

PRE ; -- preinit

 S ^XTMP("OR117","DUZ")=$G(DUZ) ;save user, if queued

QO ; -- check Inpt Med QO's for old doses

 I $G(^XTMP("ORPSJ",0)) K ^XTMP("OR117") Q  ;already done

 N ORPSJ,ORNOW,ORPOI,ORPDD,ORPIN,ORPST,ORPID,ORPDN,ORQDLG,OR0,ORDIALOG,ORIT,ORDRUG,ORPSOI,ORP,ORI,ORXX,ORDOSE,DRUG,STR

 S ORPSJ=+$O(^DIC(9.4,"C","PSJ",0)),ORNOW=$$NOW^XLFDT

 S ORPOI=+$$PTR("ORDERABLE ITEM"),ORPDD=+$$PTR("DISPENSE DRUG")

 S ORPIN=+$$PTR("INSTRUCTIONS"),ORPST=+$$PTR("STRENGTH")

 S ORPID=+$$PTR("DOSE"),ORPDN=+$$PTR("DRUG NAME")

 S ORQDLG=+$G(^XTMP("OR117","DLG")) ;find where left off, if restarted

 F  S ORQDLG=+$O(^ORD(101.41,ORQDLG)) Q:ORQDLG'>0  S OR0=$G(^(ORQDLG,0)) D

 . Q:$P(OR0,U,4)'="Q"  Q:$P(OR0,U,7)'=ORPSJ  ;Inpt Pharmacy qo's only

 . K ORDIALOG,ORXX,^TMP("ORWORD",$J),ORDOSE

 . D GETQDLG Q:'$D(ORDIALOG)  Q:'$L($G(ORDIALOG(ORPIN,1)))

 . S ORDRUG=+$G(ORDIALOG(ORPDD,1)),ORIT=+$G(ORDIALOG(ORPOI,1))

 . S ORPSOI=+$P($G(^ORD(101.43,ORIT,0)),U,2)

 . D DOSE^PSSORUTL(.ORDOSE,ORPSOI,"U","")

 . S DRUG=$G(ORDOSE("DD",ORDRUG)),STR=$P(DRUG,U,5,6)

 . D DOSE I $G(ORDRUG),'$G(ORDOSE) D

 .. S STR=$TR(STR,"^") I STR'>0 S ORDIALOG(ORPDN,1)=$P(DRUG,U) Q

 .. I $P($G(^ORD(101.43,ORIT,0)),U)'[STR S ORDIALOG(ORPST,1)=STR

 . I $G(ORXX) D SAVE^ORCMEDT0 ;save responses if changed

 . S ^XTMP("OR117","DLG")=ORQDLG

 D BULLETIN

 K ^TMP("ORWORD",$J),^TMP("ORTXT",$J),^XTMP("OR117")

PTR(X) ; -- Return ptr to prompt OR GTX X

 Q +$O(^ORD(101.41,"AB","OR GTX "_X,0))

GETQDLG ; -- Get quick order definition, build ORDIALOG()

 S ORDIALOG=+$$DEFDLG^ORCD(ORQDLG) Q:'ORDIALOG

 D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD("^ORD(101.41,"_ORQDLG_",6)")

DOSE ; -- Reformat outpt dose instance ORI, if possible/necessary

 Q:$D(ORDIALOG(ORPID,1))  ;already successfully converted

 N UD,CONJ,IDX,DOSE,MATCH,X,Y

 S UD=$G(ORDIALOG(ORPIN,1)),X=$$UP^XLFSTR(UD),MATCH=0

 S Y=$G(ORDOSE(1)) I Y D  ;check format for Total Doses

 . I X?1.N1." "1.U S X=$TR(X," "),ORXX=1 ;strip spaces

 . I Y?1"0."1.N.E,X?1"."1.N.E S X="0"_X,ORXX=1 ;leading zero's

 . I Y?1"."1.N.E,X?1"0."1.N.E S X=$E(X,2,99),ORXX=1

 ;S:UD="1/2" UD=.5 S:UD="1/3" UD=.33 S:UD="1/4" UD=.25 S:UD="3/4" UD=.75

 S CONJ=$P($G(ORDOSE("MISC")),U,3) S:$L(CONJ) CONJ=" "_CONJ

 S IDX="ORDOSE(0)" F  S IDX=$Q(@IDX) Q:IDX'?1"ORDOSE("1.N.",".N1")"  D

 . S DOSE=@IDX I $P(DOSE,U,5)=X D  Q

 .. I ORDRUG,$P(DOSE,U,6)'=ORDRUG Q  ;not a match

 .. S MATCH=MATCH+1,MATCH(MATCH)=$P(DOSE,U,1,6)

 . ;str ok?

D1 I MATCH=1 D  Q  ;Update responses

 . S Y=MATCH(1),X=$P(Y,U,5),ORXX=1

 . S:'Y X=X_CONJ_" "_$S($G(STR):$TR(STR,"^"),1:$P(DRUG,U))

 . S ORDIALOG(ORPIN,1)=X

 . S ORDIALOG(ORPDD,1)=$P(Y,U,6)

 . S ORDIALOG(ORPID,1)=$TR(Y,"^","&")_"&"_$TR($G(STR),"^","&")

 ; -- Else add qo to bulletin for review

 ;K ORDIALOG(ORPDD,1) ;clear old dispense drug?

 S:$G(ORXX) ORDIALOG(ORPIN,1)=X

 S ^XTMP("ORPSJ",ORQDLG)=""

BULLETIN ; -- Send bulletin containing qo's we couldn't convert

 N ORNOW,ORNOW90,XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,I,J,ORD0,DIFROM

 S ORNOW=$$NOW^XLFDT,ORNOW90=$$FMADD^XLFDT(ORNOW,90)

 S XMDUZ="PATCH OR*3*117 CONVERSION",XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""

 I '$G(DUZ) S I=$G(^XTMP("OR117","DUZ")) S:I XMY(I)=""

 S ^TMP("ORTXT",$J,1)="The quick order conversion of patch OR*3*117 has completed."

B1 S J=1 I $O(^XTMP("ORPSJ",0)) D

 . S ^XTMP("ORPSJ",0)=ORNOW90_U_ORNOW_"^CPRS/POE Inpt Dose conversion"

 . S J=J+1,^TMP("ORTXT",$J,J)="   "

 . S J=J+1,^TMP("ORTXT",$J,J)="The following Inpatient Pharmacy quick orders have instructions that"

 . S J=J+1,^TMP("ORTXT",$J,J)="were unable to be re-formatted:"

 . S I=0 F  S I=$O(^XTMP("ORPSJ",I)) Q:I'>0  D

 .. S ORD0=$G(^ORD(101.41,+I,0))

 .. S J=J+1,^TMP("ORTXT",$J,J)="   "_$P(ORD0,U)_"  ("_$P(ORD0,U,2)_")"

 S XMSUB="PATCH OR*3*117 CONVERSION COMPLETED"

 S XMTEXT="^TMP(""ORTXT"","_$J_"," D ^XMD

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY117   3986     printed  Mar 13, 2025@21:43:20                                                                                                                                                                                                      Page 2

ORY117    ;SLC/MKB -- post-install for OR*3*117;02:56 PM  8 May 2001

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**117**;Dec 17, 1997

 +2       ;

PRE       ; -- preinit

 +1       ;save user, if queued

           SET ^XTMP("OR117","DUZ")=$GET(DUZ)

 +2        QUIT

 +3       ;

QO        ; -- check Inpt Med QO's for old doses

 +1       ;

 +2       ;already done

           IF $GET(^XTMP("ORPSJ",0))

               KILL ^XTMP("OR117")

               QUIT

 +3        NEW ORPSJ,ORNOW,ORPOI,ORPDD,ORPIN,ORPST,ORPID,ORPDN,ORQDLG,OR0,ORDIALOG,ORIT,ORDRUG,ORPSOI,ORP,ORI,ORXX,ORDOSE,DRUG,STR

 +4        SET ORPSJ=+$ORDER(^DIC(9.4,"C","PSJ",0))

           SET ORNOW=$$NOW^XLFDT

 +5        SET ORPOI=+$$PTR("ORDERABLE ITEM")

           SET ORPDD=+$$PTR("DISPENSE DRUG")

 +6        SET ORPIN=+$$PTR("INSTRUCTIONS")

           SET ORPST=+$$PTR("STRENGTH")

 +7        SET ORPID=+$$PTR("DOSE")

           SET ORPDN=+$$PTR("DRUG NAME")

 +8       ;find where left off, if restarted

           SET ORQDLG=+$GET(^XTMP("OR117","DLG"))

 +9        FOR

               SET ORQDLG=+$ORDER(^ORD(101.41,ORQDLG))

               if ORQDLG'>0

                   QUIT

               SET OR0=$GET(^(ORQDLG,0))

               Begin DoDot:1

 +10      ;Inpt Pharmacy qo's only

                   if $PIECE(OR0,U,4)'="Q"

                       QUIT

                   if $PIECE(OR0,U,7)'=ORPSJ

                       QUIT

 +11               KILL ORDIALOG,ORXX,^TMP("ORWORD",$JOB),ORDOSE

 +12               DO GETQDLG

                   if '$DATA(ORDIALOG)

                       QUIT

                   if '$LENGTH($GET(ORDIALOG(ORPIN,1)))

                       QUIT

 +13               SET ORDRUG=+$GET(ORDIALOG(ORPDD,1))

                   SET ORIT=+$GET(ORDIALOG(ORPOI,1))

 +14               SET ORPSOI=+$PIECE($GET(^ORD(101.43,ORIT,0)),U,2)

 +15               DO DOSE^PSSORUTL(.ORDOSE,ORPSOI,"U","")

 +16               SET DRUG=$GET(ORDOSE("DD",ORDRUG))

                   SET STR=$PIECE(DRUG,U,5,6)

 +17               DO DOSE

                   IF $GET(ORDRUG)

                       IF '$GET(ORDOSE)

                           Begin DoDot:2

 +18                           SET STR=$TRANSLATE(STR,"^")

                               IF STR'>0

                                   SET ORDIALOG(ORPDN,1)=$PIECE(DRUG,U)

                                   QUIT

 +19                           IF $PIECE($GET(^ORD(101.43,ORIT,0)),U)'[STR

                                   SET ORDIALOG(ORPST,1)=STR

                           End DoDot:2

 +20      ;save responses if changed

                   IF $GET(ORXX)

                       DO SAVE^ORCMEDT0

 +21               SET ^XTMP("OR117","DLG")=ORQDLG

               End DoDot:1

 +22      ;

 +23       DO BULLETIN

 +24       KILL ^TMP("ORWORD",$JOB),^TMP("ORTXT",$JOB),^XTMP("OR117")

 +25       QUIT

 +26      ;

PTR(X)    ; -- Return ptr to prompt OR GTX X

 +1        QUIT +$ORDER(^ORD(101.41,"AB","OR GTX "_X,0))

 +2       ;

GETQDLG   ; -- Get quick order definition, build ORDIALOG()

 +1        SET ORDIALOG=+$$DEFDLG^ORCD(ORQDLG)

           if 'ORDIALOG

               QUIT

 +2        DO GETDLG^ORCD(ORDIALOG)

           DO GETORDER^ORCD("^ORD(101.41,"_ORQDLG_",6)")

 +3        QUIT

 +4       ;

DOSE      ; -- Reformat outpt dose instance ORI, if possible/necessary

 +1       ;already successfully converted

           if $DATA(ORDIALOG(ORPID,1))

               QUIT

 +2        NEW UD,CONJ,IDX,DOSE,MATCH,X,Y

 +3        SET UD=$GET(ORDIALOG(ORPIN,1))

           SET X=$$UP^XLFSTR(UD)

           SET MATCH=0

 +4       ;check format for Total Doses

           SET Y=$GET(ORDOSE(1))

           IF Y

               Begin DoDot:1

 +5       ;strip spaces

                   IF X?1.N1." "1.U

                       SET X=$TRANSLATE(X," ")

                       SET ORXX=1

 +6       ;leading zero's

                   IF Y?1"0."1.N.E

                       IF X?1"."1.N.E

                           SET X="0"_X

                           SET ORXX=1

 +7                IF Y?1"."1.N.E

                       IF X?1"0."1.N.E

                           SET X=$EXTRACT(X,2,99)

                           SET ORXX=1

               End DoDot:1

 +8       ;S:UD="1/2" UD=.5 S:UD="1/3" UD=.33 S:UD="1/4" UD=.25 S:UD="3/4" UD=.75

 +9        SET CONJ=$PIECE($GET(ORDOSE("MISC")),U,3)

           if $LENGTH(CONJ)

               SET CONJ=" "_CONJ

 +10       SET IDX="ORDOSE(0)"

FOR

               SET IDX=$QUERY(@IDX)

               if IDX'?1"ORDOSE("1.N.",".N1")"

                   QUIT

               Begin DoDot:1

 +11               SET DOSE=@IDX

                   IF $PIECE(DOSE,U,5)=X

                       Begin DoDot:2

 +12      ;not a match

                           IF ORDRUG

                               IF $PIECE(DOSE,U,6)'=ORDRUG

                                   QUIT

 +13                       SET MATCH=MATCH+1

                           SET MATCH(MATCH)=$PIECE(DOSE,U,1,6)

                       End DoDot:2

                       QUIT

 +14      ;str ok?

               End DoDot:1

D1        ;Update responses

           IF MATCH=1

               Begin DoDot:1

 +1                SET Y=MATCH(1)

                   SET X=$PIECE(Y,U,5)

                   SET ORXX=1

 +2                if 'Y

                       SET X=X_CONJ_" "_$SELECT($GET(STR):$TRANSLATE(STR,"^"),1:$PIECE(DRUG,U))

 +3                SET ORDIALOG(ORPIN,1)=X

 +4                SET ORDIALOG(ORPDD,1)=$PIECE(Y,U,6)

 +5                SET ORDIALOG(ORPID,1)=$TRANSLATE(Y,"^","&")_"&"_$TRANSLATE($GET(STR),"^","&")

               End DoDot:1

               QUIT

 +6       ; -- Else add qo to bulletin for review

 +7       ;K ORDIALOG(ORPDD,1) ;clear old dispense drug?

 +8        if $GET(ORXX)

               SET ORDIALOG(ORPIN,1)=X

 +9        SET ^XTMP("ORPSJ",ORQDLG)=""

 +10       QUIT

 +11      ;

BULLETIN  ; -- Send bulletin containing qo's we couldn't convert

 +1        NEW ORNOW,ORNOW90,XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,I,J,ORD0,DIFROM

 +2        SET ORNOW=$$NOW^XLFDT

           SET ORNOW90=$$FMADD^XLFDT(ORNOW,90)

 +3        SET XMDUZ="PATCH OR*3*117 CONVERSION"

           SET XMY(.5)=""

           if $GET(DUZ)

               SET XMY(DUZ)=""

 +4        IF '$GET(DUZ)

               SET I=$GET(^XTMP("OR117","DUZ"))

               if I

                   SET XMY(I)=""

 +5        SET ^TMP("ORTXT",$JOB,1)="The quick order conversion of patch OR*3*117 has completed."

B1         SET J=1

           IF $ORDER(^XTMP("ORPSJ",0))

               Begin DoDot:1

 +1                SET ^XTMP("ORPSJ",0)=ORNOW90_U_ORNOW_"^CPRS/POE Inpt Dose conversion"

 +2                SET J=J+1

                   SET ^TMP("ORTXT",$JOB,J)="   "

 +3                SET J=J+1

                   SET ^TMP("ORTXT",$JOB,J)="The following Inpatient Pharmacy quick orders have instructions that"

 +4                SET J=J+1

                   SET ^TMP("ORTXT",$JOB,J)="were unable to be re-formatted:"

 +5                SET I=0

FOR

                       SET I=$ORDER(^XTMP("ORPSJ",I))

                       if I'>0

                           QUIT

                       Begin DoDot:2

 +6                        SET ORD0=$GET(^ORD(101.41,+I,0))

 +7                        SET J=J+1

                           SET ^TMP("ORTXT",$JOB,J)="   "_$PIECE(ORD0,U)_"  ("_$PIECE(ORD0,U,2)_")"

                       End DoDot:2

               End DoDot:1

 +8        SET XMSUB="PATCH OR*3*117 CONVERSION COMPLETED"

 +9        SET XMTEXT="^TMP(""ORTXT"","_$JOB_","

           DO ^XMD

 +10       QUIT

ORY117.m