- 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 Jan 18, 2025@03:29:42 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