Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORCK101

ORCK101.m

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