ORCK101 ;SLC/JFR-OR 49 CHECK UTILITIES ;7/27/98
;;2.5;ORDER ENTRY/RESULTS REPORTING;**49**;Jan 08, 1993
TOP ; from patch options
N ORTOP,%ZIS,IOP,TAG
W !,"Select the printer to which the reports will be queued:",!
S IOP="Q",%ZIS="N"
D ^%ZIS
I POP W !,"That device is not available or none selected" Q
I '$D(IO("Q")) W !!,"The reports must be queued!",! G TOP
S ORTOP=1 W !!,"Reports will be sent to ",ION
F TAG="PKGFL","PROT","NMSP","XACTION" D
. S ZTRTN=TAG_"^ORCK101",ZTDESC="OR*2.5*49 PROTOCOL CHECK"
. S ZTDTH=$H,ZTSAVE("ORTOP")="",ZTIO=ION
. D ^%ZTLOAD
D HOME^%ZIS
K ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSAVE
Q
XACTION ;check extended actions for column width
I $D(ZTQUEUED) S ZTREQ="@"
N ORIEN,CTR,TMPGBL,CHECK
S CHECK="Extended Action Order Set check",TMPGBL="ORXACT"
S (CTR,ORIEN)=0
F S ORIEN=$O(^ORD(101,ORIEN)) Q:'ORIEN I $P($G(^(ORIEN,0)),U,4)="X" D
. Q:'+$G(^ORD(101,ORIEN,4)) S CTR=CTR+1
. S ^TMP(TMPGBL,$J,CTR)=$P(^ORD(101,ORIEN,0),U)_" has the COLUMN WIDTH field defined"
I '$D(ORTOP) D DEVICE Q ;ok to call linetag
D PRINT
Q
PKGFL ;check file 9.4 for duplicates
I $D(ZTQUEUED) S ZTREQ="@"
N PKG,CHECK,I,N,P,NM,PREF,TMPGBL,CTR
S CTR=0,CHECK="PACKAGE (#9.4) file check",TMPGBL="ORPKG"
F I=1:1 S PKG=$P($T(LIST+I),";;",2) Q:PKG="QUIT" D
. S NM=$P(PKG,"^"),PREF=$P(PKG,"^",2)
. S N=$O(^DIC(9.4,"B",NM,0)) D:'N S N=$O(^DIC(9.4,"B",NM,N)) I N D
.. S CTR=CTR+1
.. S ^TMP(TMPGBL,$J,CTR)=NM_" has "_$S(N:"a duplicate",1:"no")_" name entry in the PACKAGE file"
.. Q
. S P=$O(^DIC(9.4,"C",PREF,0)) D:'P S P=$O(^DIC(9.4,"C",PREF,P)) I P D
.. S CTR=CTR+1
.. S ^TMP(TMPGBL,$J,CTR)="There is "_$S(P:"a duplicate",1:"no")_" prefix entry of "_PREF_" in the PACKAGE file"
.. Q
. I $O(^DIC(9.4,"B",NM,0))'=$O(^DIC(9.4,"C",PREF,0)) D
.. S CTR=CTR+1
.. S ^TMP(TMPGBL,$J,CTR)="The name and prefix for "_NM_" are not part of the same entry"
. Q
I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
D PRINT
Q
LIST ;list to check
;;LAB SERVICE^LR
;;INPATIENT MEDICATIONS^PSJ
;;OUTPATIENT PHARMACY^PSO
;;DIETETICS^FH
;;RADIOLOGY/NUCLEAR MEDICINE^RA
;;NURSING SERVICE^NUR
;;GEN. MED. REC. - VITALS^GMRV
;;ORDER ENTRY/RESULTS REPORTING^OR
;;QUIT
PROT ;LOOP 101 AND LOOK AT 10 FIELD FOR DUPS
I $D(ZTQUEUED) S ZTREQ="@"
N TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
S (CTR1,ORZIEN)=0,TMPGBL="ORDUPS"
S CHECK="Duplicate Items in PROTOCOL file check"
F S ORZIEN=$O(^ORD(101,ORZIEN)) Q:'ORZIEN D:$P(^(ORZIEN,0),"^",4)="D"
. S ORZ10IEN=0
. F S ORZ10IEN=$O(^ORD(101,ORZIEN,10,"B",ORZ10IEN)) Q:'ORZ10IEN D
. . S (PTR,CTR)=0
. . F S PTR=$O(^ORD(101,ORZIEN,10,"B",ORZ10IEN,PTR)) Q:'PTR D
. . . S CTR=CTR+1 I CTR>1 S CTR1=CTR1+1
. . . I S ^TMP(TMPGBL,$J,CTR1)=$P(^ORD(101,ORZIEN,0),U)
. . Q
. Q
I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
D PRINT
Q
DLG ; FIND DUPS IN FILE 101.41
N TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
S (CTR1,ORZIEN)=0,TMPGBL="ORDLGDUP"
S CHECK="Duplicate Items in ORDER DIALOG file"
F S ORZIEN=$O(^ORD(101.41,ORZIEN)) Q:'ORZIEN D:$P(^(ORZIEN,0),"^",4)="D"
. S ORZ10IEN=0
. F S ORZ10IEN=$O(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN)) Q:'ORZ10IEN D
. . S (PTR,CTR)=0
. . F S PTR=$O(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN,PTR)) Q:'PTR D
. . . S CTR=CTR+1 I CTR>1 S CTR1=CTR1+1
. . . I S ^TMP(TMPGBL,$J,CTR1)=$P(^ORD(101.41,ORZIEN,0),U)
. . Q
. Q
I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
D PRINT
Q
NMSP ;loop to find protocols with improper namespace
I $D(ZTQUEUED) S ZTREQ="@"
D DT^DICRW
N CTR,CHECK,TMPGBL,ORZIEN,PKG,GMRC,DIC,X,Y,BADPK,ORZNM,ORZPKG
S DIC=9.4,DIC(0)="XM",BADPK=0
F X="FH","GMRC","GMRV","LR","PSJ","RA" Q:(BADPK) D
. D ^DIC I +Y<0 S BADPK=1 Q
. S PKG(+Y)=X I X="GMRC" S GMRC=+Y
I BADPK D
. S ^TMP("ORPROT",$J,1)="The PACKAGE file should be checked for duplicate entries or PREFIXES."
. S ^TMP("ORPROT",$J,2)="Unable to continue namespace check."
. S ^TMP("ORPROT",$J,3)=" "
. S ^TMP("ORPROT",$J,4)="This review should be repeated after the PACKAGE file is corrected."
S (CTR,ORZIEN)=0
S TMPGBL="ORPROT",CHECK="Protocol namespace check"
I 'BADPK F S ORZIEN=$O(^ORD(101,ORZIEN)) Q:'ORZIEN D
. I "QXM"[$P(^ORD(101,ORZIEN,0),"^",4) Q ; don't check menus / ord sets
. S ORZPKG=$P(^ORD(101,ORZIEN,0),"^",12) Q:'ORZPKG Q:'$D(PKG(ORZPKG))
. I ORZPKG=GMRC Q:'$$OK(ORZIEN) ;special names for consults
. S ORZNM=$E($P(^ORD(101,ORZIEN,0),U),1,$S(ORZPKG=GMRC:5,1:$L(PKG(ORZPKG))))
. I '$S(ORZPKG=GMRC:"GMRCTGMRCR"[ORZNM,1:ORZNM=PKG(ORZPKG)) D
. . S CTR=CTR+1
. . S ^TMP(TMPGBL,$J,CTR)=$P(^ORD(101,ORZIEN,0),U)
. . Q
. Q
I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
D PRINT
Q
OK(PROT) ;only check ordering protocols
I $P(^ORD(101,PROT,0),U,3)'="O" Q 0
I $P(^ORD(101,PROT,0),U)["PLACE" Q 0
I $P(^ORD(101,PROT,0),U)["URGENCY" Q 0
I $P(^ORD(101,PROT,0),U)["GMRCO" Q 0
Q 1
PRINT ;the results are in
N CTR,DONE
U IO
I '$D(^TMP(TMPGBL,$J)) S ^TMP(TMPGBL,$J,1)="No problems with "_CHECK
W:$E(IOST,1,2)="C-" @IOF
D PAGE(0)
S CTR=0 F S CTR=$O(^TMP(TMPGBL,$J,CTR)) Q:'CTR!($D(DONE)) D
. I $Y>(IOSL-5) D PAGE(1) Q:$G(DONE)
. W !,^TMP(TMPGBL,$J,CTR)
. Q
D ^%ZISC K CTR,DONE,ORTOP
CLEAN ;sweep up
K ^TMP(TMPGBL,$J)
K TMPGBL,CHECK
Q
FIND ; FIND ITEMS IN 101 AND THEIR POSITION
N DIC,ITEM,MEN,X,Y,ITPOS
D DT^DICRW
K DIC S DIC=101,DIC(0)="AEMNQ" D ^DIC
I $D(DUOUT)!($D(DTOUT)) Q
W !!,$P($G(^ORD(101,+Y,0)),"^")
I '$D(^ORD(101,"AD",+Y)) W !,?3,"Not contained on any menus!" QUIT
S ITEM=+Y
S MEN=0 F S MEN=$O(^ORD(101,"AD",ITEM,MEN)) Q:'MEN D
. W !,?5,"is part of ",$P($G(^ORD(101,MEN,0)),"^")
. S ITPOS=$$FINDXUTL^ORCMEDT1(MEN,ITEM)
. W ?50,"Column: ",$P(ITPOS,".",2),?65,"Row: ",$P(ITPOS,".")
. Q
Q
EST ; estimate global growth in ^OR and ^PSRX
W !,"Select the printer to which the estimate will be sent:",!
S IOP="Q",%ZIS="N"
D ^%ZIS
I POP W !,"That device is not available or none selected" Q
I '$D(IO("Q")) D G EST
. W !!,"The estimate may take some time. It must be queued!",!
S ZTRTN="QGROW^ORCK101",ZTDESC="Estimate of CPRS global growth"
S ZTIO=ION,ZTDTH=$H D ^%ZTLOAD
W !!,$S($G(ZTSK):("Task # "_ZTSK),1:"Unable to queue,try later!")
D HOME^%ZIS
K %ZIS,POP,ZTDESC,ZTIO,ZTRTN,ZTSK
Q
QGROW ;task to do estimate
S ZTREQ="@"
S BKFILL=$$PSOBKFL
S ORENT=$P(^OR(100,0),"^",4),RXENT=$P(^PSRX(0),"^",4)
S ORBLK=(ORENT+BKFILL)*($S(^%ZOSF("OS")="DSM":.71,1:.35))
S RXBLK=RXENT*($S(^%ZOSF("OS")="DSM":.67,1:.37))
U IO
W !,"Estimate of global growth from CPRS Installation",!
F DASH=1:1:78 W "-"
W !!,"Based on the number of entries currently in the ^PSRX and ^OR globals,"
W !,"the following are estimates of post-installion requirements."
W !,"The globals will continue to grow as implementation of CPRS proceeds"
W !!,"The ^PSRX global will require approximately ",RXBLK," blocks."
W !!,"Approximately ",BKFILL," prescriptions will be backfilled into the ORDER (#100) file."
W !!,"The ^OR global will require approximately ",ORBLK," blocks."
K BKFILL,DASH,ORBLK,ORENT,RXBLK,RXENT
Q
PAGE(FEED) ; FEED ONE
N DASH,DIR
I FEED,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR I Y<1 S DONE=1 Q
W:FEED @IOF
W "OR*2.5*49 - ",CHECK
W ! F DASH=1:1:78 W "-"
Q
DEVICE ;
S %ZIS="QM" D ^%ZIS I POP D CLEAN Q
I $D(IO("Q")) D QUE,^%ZISC,CLEAN Q
D PRINT
Q
QUE ; send to TM
S ZTSAVE("^TMP(TMPGBL,$J,")="",ZTSAVE("TMPGBL")="",ZTSAVE("CHECK")=""
S ZTDTH=$H,ZTDESC="OR*2.5*49 Protocol examination"
S ZTRTN="PRINT^ORCK101"
S ZTIO=IO
D ^%ZTLOAD
K ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH
Q
PSOBKFL() ;estimate # of RX's to be backfilled into ^OR
; Thks to Ron R.
N PDFN,PSD,PSIN,PSODATE,PSOTOT,X,X1,X2
S X1=DT,X2=-121 D C^%DTC S PSODATE=X
S PSOTOT=0
F PDFN=0:0 S PDFN=$O(^PS(55,PDFN)) Q:'PDFN D
.F PSD=PSODATE:0 S PSD=$O(^PS(55,PDFN,"P","A",PSD)) Q:'PSD F PSIN=0:0 S PSIN=$O(^PS(55,PDFN,"P","A",PSD,PSIN)) Q:'PSIN I $D(^PSRX(PSIN,0)) D
..I $P($G(^PSRX(PSIN,0)),"^",15)=13!($P($G(^(0)),"^",15)=10)!('$P($G(^(0)),"^",2)) Q
..S PSOTOT=PSOTOT+1
Q PSOTOT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCK101 8133 printed Sep 23, 2025@20:04:49 Page 2
ORCK101 ;SLC/JFR-OR 49 CHECK UTILITIES ;7/27/98
+1 ;;2.5;ORDER ENTRY/RESULTS REPORTING;**49**;Jan 08, 1993
TOP ; from patch options
+1 NEW ORTOP,%ZIS,IOP,TAG
+2 WRITE !,"Select the printer to which the reports will be queued:",!
+3 SET IOP="Q"
SET %ZIS="N"
+4 DO ^%ZIS
+5 IF POP
WRITE !,"That device is not available or none selected"
QUIT
+6 IF '$DATA(IO("Q"))
WRITE !!,"The reports must be queued!",!
GOTO TOP
+7 SET ORTOP=1
WRITE !!,"Reports will be sent to ",ION
+8 FOR TAG="PKGFL","PROT","NMSP","XACTION"
Begin DoDot:1
+9 SET ZTRTN=TAG_"^ORCK101"
SET ZTDESC="OR*2.5*49 PROTOCOL CHECK"
+10 SET ZTDTH=$HOROLOG
SET ZTSAVE("ORTOP")=""
SET ZTIO=ION
+11 DO ^%ZTLOAD
End DoDot:1
+12 DO HOME^%ZIS
+13 KILL ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSAVE
+14 QUIT
XACTION ;check extended actions for column width
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW ORIEN,CTR,TMPGBL,CHECK
+3 SET CHECK="Extended Action Order Set check"
SET TMPGBL="ORXACT"
+4 SET (CTR,ORIEN)=0
+5 FOR
SET ORIEN=$ORDER(^ORD(101,ORIEN))
if 'ORIEN
QUIT
IF $PIECE($GET(^(ORIEN,0)),U,4)="X"
Begin DoDot:1
+6 if '+$GET(^ORD(101,ORIEN,4))
QUIT
SET CTR=CTR+1
+7 SET ^TMP(TMPGBL,$JOB,CTR)=$PIECE(^ORD(101,ORIEN,0),U)_" has the COLUMN WIDTH field defined"
End DoDot:1
+8 ;ok to call linetag
IF '$DATA(ORTOP)
DO DEVICE
QUIT
+9 DO PRINT
+10 QUIT
PKGFL ;check file 9.4 for duplicates
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW PKG,CHECK,I,N,P,NM,PREF,TMPGBL,CTR
+3 SET CTR=0
SET CHECK="PACKAGE (#9.4) file check"
SET TMPGBL="ORPKG"
+4 FOR I=1:1
SET PKG=$PIECE($TEXT(LIST+I),";;",2)
if PKG="QUIT"
QUIT
Begin DoDot:1
+5 SET NM=$PIECE(PKG,"^")
SET PREF=$PIECE(PKG,"^",2)
+6 SET N=$ORDER(^DIC(9.4,"B",NM,0))
if 'N
Begin DoDot:2
+7 SET CTR=CTR+1
+8 SET ^TMP(TMPGBL,$JOB,CTR)=NM_" has "_$SELECT(N:"a duplicate",1:"no")_" name entry in the PACKAGE file"
+9 QUIT
End DoDot:2
SET N=$ORDER(^DIC(9.4,"B",NM,N))
IF N
Begin DoDot:2
End DoDot:2
+10 SET P=$ORDER(^DIC(9.4,"C",PREF,0))
if 'P
Begin DoDot:2
+11 SET CTR=CTR+1
+12 SET ^TMP(TMPGBL,$JOB,CTR)="There is "_$SELECT(P:"a duplicate",1:"no")_" prefix entry of "_PREF_" in the PACKAGE file"
+13 QUIT
End DoDot:2
SET P=$ORDER(^DIC(9.4,"C",PREF,P))
IF P
Begin DoDot:2
End DoDot:2
+14 IF $ORDER(^DIC(9.4,"B",NM,0))'=$ORDER(^DIC(9.4,"C",PREF,0))
Begin DoDot:2
+15 SET CTR=CTR+1
+16 SET ^TMP(TMPGBL,$JOB,CTR)="The name and prefix for "_NM_" are not part of the same entry"
End DoDot:2
+17 QUIT
End DoDot:1
+18 ;ok to call from linetag
IF '$DATA(ORTOP)
DO DEVICE
QUIT
+19 DO PRINT
+20 QUIT
LIST ;list to check
+1 ;;LAB SERVICE^LR
+2 ;;INPATIENT MEDICATIONS^PSJ
+3 ;;OUTPATIENT PHARMACY^PSO
+4 ;;DIETETICS^FH
+5 ;;RADIOLOGY/NUCLEAR MEDICINE^RA
+6 ;;NURSING SERVICE^NUR
+7 ;;GEN. MED. REC. - VITALS^GMRV
+8 ;;ORDER ENTRY/RESULTS REPORTING^OR
+9 ;;QUIT
PROT ;LOOP 101 AND LOOK AT 10 FIELD FOR DUPS
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
+3 SET (CTR1,ORZIEN)=0
SET TMPGBL="ORDUPS"
+4 SET CHECK="Duplicate Items in PROTOCOL file check"
+5 FOR
SET ORZIEN=$ORDER(^ORD(101,ORZIEN))
if 'ORZIEN
QUIT
if $PIECE(^(ORZIEN,0),"^",4)="D"
Begin DoDot:1
+6 SET ORZ10IEN=0
+7 FOR
SET ORZ10IEN=$ORDER(^ORD(101,ORZIEN,10,"B",ORZ10IEN))
if 'ORZ10IEN
QUIT
Begin DoDot:2
+8 SET (PTR,CTR)=0
+9 FOR
SET PTR=$ORDER(^ORD(101,ORZIEN,10,"B",ORZ10IEN,PTR))
if 'PTR
QUIT
Begin DoDot:3
+10 SET CTR=CTR+1
IF CTR>1
SET CTR1=CTR1+1
+11 IF $TEST
SET ^TMP(TMPGBL,$JOB,CTR1)=$PIECE(^ORD(101,ORZIEN,0),U)
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 ;ok to call from linetag
IF '$DATA(ORTOP)
DO DEVICE
QUIT
+15 DO PRINT
+16 QUIT
DLG ; FIND DUPS IN FILE 101.41
+1 NEW TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
+2 SET (CTR1,ORZIEN)=0
SET TMPGBL="ORDLGDUP"
+3 SET CHECK="Duplicate Items in ORDER DIALOG file"
+4 FOR
SET ORZIEN=$ORDER(^ORD(101.41,ORZIEN))
if 'ORZIEN
QUIT
if $PIECE(^(ORZIEN,0),"^",4)="D"
Begin DoDot:1
+5 SET ORZ10IEN=0
+6 FOR
SET ORZ10IEN=$ORDER(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN))
if 'ORZ10IEN
QUIT
Begin DoDot:2
+7 SET (PTR,CTR)=0
+8 FOR
SET PTR=$ORDER(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN,PTR))
if 'PTR
QUIT
Begin DoDot:3
+9 SET CTR=CTR+1
IF CTR>1
SET CTR1=CTR1+1
+10 IF $TEST
SET ^TMP(TMPGBL,$JOB,CTR1)=$PIECE(^ORD(101.41,ORZIEN,0),U)
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 ;ok to call from linetag
IF '$DATA(ORTOP)
DO DEVICE
QUIT
+14 DO PRINT
+15 QUIT
NMSP ;loop to find protocols with improper namespace
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 DO DT^DICRW
+3 NEW CTR,CHECK,TMPGBL,ORZIEN,PKG,GMRC,DIC,X,Y,BADPK,ORZNM,ORZPKG
+4 SET DIC=9.4
SET DIC(0)="XM"
SET BADPK=0
+5 FOR X="FH","GMRC","GMRV","LR","PSJ","RA"
if (BADPK)
QUIT
Begin DoDot:1
+6 DO ^DIC
IF +Y<0
SET BADPK=1
QUIT
+7 SET PKG(+Y)=X
IF X="GMRC"
SET GMRC=+Y
End DoDot:1
+8 IF BADPK
Begin DoDot:1
+9 SET ^TMP("ORPROT",$JOB,1)="The PACKAGE file should be checked for duplicate entries or PREFIXES."
+10 SET ^TMP("ORPROT",$JOB,2)="Unable to continue namespace check."
+11 SET ^TMP("ORPROT",$JOB,3)=" "
+12 SET ^TMP("ORPROT",$JOB,4)="This review should be repeated after the PACKAGE file is corrected."
End DoDot:1
+13 SET (CTR,ORZIEN)=0
+14 SET TMPGBL="ORPROT"
SET CHECK="Protocol namespace check"
+15 IF 'BADPK
FOR
SET ORZIEN=$ORDER(^ORD(101,ORZIEN))
if 'ORZIEN
QUIT
Begin DoDot:1
+16 ; don't check menus / ord sets
IF "QXM"[$PIECE(^ORD(101,ORZIEN,0),"^",4)
QUIT
+17 SET ORZPKG=$PIECE(^ORD(101,ORZIEN,0),"^",12)
if 'ORZPKG
QUIT
if '$DATA(PKG(ORZPKG))
QUIT
+18 ;special names for consults
IF ORZPKG=GMRC
if '$$OK(ORZIEN)
QUIT
+19 SET ORZNM=$EXTRACT($PIECE(^ORD(101,ORZIEN,0),U),1,$SELECT(ORZPKG=GMRC:5,1:$LENGTH(PKG(ORZPKG))))
+20 IF '$SELECT(ORZPKG=GMRC:"GMRCTGMRCR"[ORZNM,1:ORZNM=PKG(ORZPKG))
Begin DoDot:2
+21 SET CTR=CTR+1
+22 SET ^TMP(TMPGBL,$JOB,CTR)=$PIECE(^ORD(101,ORZIEN,0),U)
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 ;ok to call from linetag
IF '$DATA(ORTOP)
DO DEVICE
QUIT
+26 DO PRINT
+27 QUIT
OK(PROT) ;only check ordering protocols
+1 IF $PIECE(^ORD(101,PROT,0),U,3)'="O"
QUIT 0
+2 IF $PIECE(^ORD(101,PROT,0),U)["PLACE"
QUIT 0
+3 IF $PIECE(^ORD(101,PROT,0),U)["URGENCY"
QUIT 0
+4 IF $PIECE(^ORD(101,PROT,0),U)["GMRCO"
QUIT 0
+5 QUIT 1
PRINT ;the results are in
+1 NEW CTR,DONE
+2 USE IO
+3 IF '$DATA(^TMP(TMPGBL,$JOB))
SET ^TMP(TMPGBL,$JOB,1)="No problems with "_CHECK
+4 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 DO PAGE(0)
+6 SET CTR=0
FOR
SET CTR=$ORDER(^TMP(TMPGBL,$JOB,CTR))
if 'CTR!($DATA(DONE))
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-5)
DO PAGE(1)
if $GET(DONE)
QUIT
+8 WRITE !,^TMP(TMPGBL,$JOB,CTR)
+9 QUIT
End DoDot:1
+10 DO ^%ZISC
KILL CTR,DONE,ORTOP
CLEAN ;sweep up
+1 KILL ^TMP(TMPGBL,$JOB)
+2 KILL TMPGBL,CHECK
+3 QUIT
FIND ; FIND ITEMS IN 101 AND THEIR POSITION
+1 NEW DIC,ITEM,MEN,X,Y,ITPOS
+2 DO DT^DICRW
+3 KILL DIC
SET DIC=101
SET DIC(0)="AEMNQ"
DO ^DIC
+4 IF $DATA(DUOUT)!($DATA(DTOUT))
QUIT
+5 WRITE !!,$PIECE($GET(^ORD(101,+Y,0)),"^")
+6 IF '$DATA(^ORD(101,"AD",+Y))
WRITE !,?3,"Not contained on any menus!"
QUIT
+7 SET ITEM=+Y
+8 SET MEN=0
FOR
SET MEN=$ORDER(^ORD(101,"AD",ITEM,MEN))
if 'MEN
QUIT
Begin DoDot:1
+9 WRITE !,?5,"is part of ",$PIECE($GET(^ORD(101,MEN,0)),"^")
+10 SET ITPOS=$$FINDXUTL^ORCMEDT1(MEN,ITEM)
+11 WRITE ?50,"Column: ",$PIECE(ITPOS,".",2),?65,"Row: ",$PIECE(ITPOS,".")
+12 QUIT
End DoDot:1
+13 QUIT
EST ; estimate global growth in ^OR and ^PSRX
+1 WRITE !,"Select the printer to which the estimate will be sent:",!
+2 SET IOP="Q"
SET %ZIS="N"
+3 DO ^%ZIS
+4 IF POP
WRITE !,"That device is not available or none selected"
QUIT
+5 IF '$DATA(IO("Q"))
Begin DoDot:1
+6 WRITE !!,"The estimate may take some time. It must be queued!",!
End DoDot:1
GOTO EST
+7 SET ZTRTN="QGROW^ORCK101"
SET ZTDESC="Estimate of CPRS global growth"
+8 SET ZTIO=ION
SET ZTDTH=$HOROLOG
DO ^%ZTLOAD
+9 WRITE !!,$SELECT($GET(ZTSK):("Task # "_ZTSK),1:"Unable to queue,try later!")
+10 DO HOME^%ZIS
+11 KILL %ZIS,POP,ZTDESC,ZTIO,ZTRTN,ZTSK
+12 QUIT
QGROW ;task to do estimate
+1 SET ZTREQ="@"
+2 SET BKFILL=$$PSOBKFL
+3 SET ORENT=$PIECE(^OR(100,0),"^",4)
SET RXENT=$PIECE(^PSRX(0),"^",4)
+4 SET ORBLK=(ORENT+BKFILL)*($SELECT(^%ZOSF("OS")="DSM":.71,1:.35))
+5 SET RXBLK=RXENT*($SELECT(^%ZOSF("OS")="DSM":.67,1:.37))
+6 USE IO
+7 WRITE !,"Estimate of global growth from CPRS Installation",!
+8 FOR DASH=1:1:78
WRITE "-"
+9 WRITE !!,"Based on the number of entries currently in the ^PSRX and ^OR globals,"
+10 WRITE !,"the following are estimates of post-installion requirements."
+11 WRITE !,"The globals will continue to grow as implementation of CPRS proceeds"
+12 WRITE !!,"The ^PSRX global will require approximately ",RXBLK," blocks."
+13 WRITE !!,"Approximately ",BKFILL," prescriptions will be backfilled into the ORDER (#100) file."
+14 WRITE !!,"The ^OR global will require approximately ",ORBLK," blocks."
+15 KILL BKFILL,DASH,ORBLK,ORENT,RXBLK,RXENT
+16 QUIT
PAGE(FEED) ; FEED ONE
+1 NEW DASH,DIR
+2 IF FEED
IF $EXTRACT(IOST,1,2)["C-"
SET DIR(0)="E"
DO ^DIR
IF Y<1
SET DONE=1
QUIT
+3 if FEED
WRITE @IOF
+4 WRITE "OR*2.5*49 - ",CHECK
+5 WRITE !
FOR DASH=1:1:78
WRITE "-"
+6 QUIT
DEVICE ;
+1 SET %ZIS="QM"
DO ^%ZIS
IF POP
DO CLEAN
QUIT
+2 IF $DATA(IO("Q"))
DO QUE
DO ^%ZISC
DO CLEAN
QUIT
+3 DO PRINT
+4 QUIT
QUE ; send to TM
+1 SET ZTSAVE("^TMP(TMPGBL,$J,")=""
SET ZTSAVE("TMPGBL")=""
SET ZTSAVE("CHECK")=""
+2 SET ZTDTH=$HOROLOG
SET ZTDESC="OR*2.5*49 Protocol examination"
+3 SET ZTRTN="PRINT^ORCK101"
+4 SET ZTIO=IO
+5 DO ^%ZTLOAD
+6 KILL ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH
+7 QUIT
PSOBKFL() ;estimate # of RX's to be backfilled into ^OR
+1 ; Thks to Ron R.
+2 NEW PDFN,PSD,PSIN,PSODATE,PSOTOT,X,X1,X2
+3 SET X1=DT
SET X2=-121
DO C^%DTC
SET PSODATE=X
+4 SET PSOTOT=0
+5 FOR PDFN=0:0
SET PDFN=$ORDER(^PS(55,PDFN))
if 'PDFN
QUIT
Begin DoDot:1
+6 FOR PSD=PSODATE:0
SET PSD=$ORDER(^PS(55,PDFN,"P","A",PSD))
if 'PSD
QUIT
FOR PSIN=0:0
SET PSIN=$ORDER(^PS(55,PDFN,"P","A",PSD,PSIN))
if 'PSIN
QUIT
IF $DATA(^PSRX(PSIN,0))
Begin DoDot:2
+7 IF $PIECE($GET(^PSRX(PSIN,0)),"^",15)=13!($PIECE($GET(^(0)),"^",15)=10)!('$PIECE($GET(^(0)),"^",2))
QUIT
+8 SET PSOTOT=PSOTOT+1
End DoDot:2
End DoDot:1
+9 QUIT PSOTOT
