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

SROVAR.m

Go to the documentation of this file.
  1. SROVAR ;BIR/MAM,ADM - SITE PARAMETERS ; 7/21/09 1:37pm
  1. ;;3.0;Surgery;**17,38,48,67,77,50,87,88,102,107,100,134,144,157,171,187**;24 Jun 93;Build 4
  1. ;
  1. ; Reference to ^TMP("CSLSUR1" supported by DBIA #3498
  1. ;
  1. K ^TMP("CSLSUR1",$J),^TMP("SRPFSS",$J) D CLEAR
  1. I $D(SRSITE) Q
  1. D CPT
  1. K SRL S (SRCNT,X)=0 F S X=$O(^SRO(133,X)) Q:'X I '$P($G(^SRO(133,X,0)),"^",21) S SRCNT=SRCNT+1,SRL(SRCNT)=X
  1. I SRCNT=1 S SRSITE=SRL(1) G SET
  1. K XQUIT,DIR W ! I SRCNT>1 S DIR("?",1)=" Because there is more than one division in the SURGERY SITE PARAMETERS",DIR("?")=" file, a division must be selected."
  1. S DIR(0)="P^133:EM",DIR("A")="Select Division",DIR("S")="I '$P(^SRO(133,+Y,0),U,21)" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) D ^SRSKILL S XQUIT="" Q
  1. S SRSITE=+Y
  1. SET ; set site parameters
  1. S S(0)=^SRO(133,SRSITE,0),SRSITE("AML")=$P(S(0),"^",4),SRSITE("REQ")=$P(S(0),"^",2) K:SRSITE("REQ")="" SRSITE("REQ")
  1. S SRSITE("IV")=$P(S(0),"^",7) K:SRSITE("IV")="" SRSITE("IV")
  1. S SRSITE("DIV")=$P(S(0),"^"),SRSITE("SITE")=$$GET1^DIQ(4,SRSITE("DIV"),.01)
  1. S SRSITE("NRPT")=$P(S(0),"^",6) I SRSITE("NRPT")="" S SRSITE("NRPT")=1
  1. I '$D(SRSITE("OPTION")),$D(XQY) S SRSITE("OPTION")=XQY
  1. K S
  1. Q
  1. CPT ; display CPT copyright notice
  1. N SRCPT,SRDIV S (SRCPT,SRDIV)=0 F S SRDIV=$O(^SRO(133,SRDIV)) Q:'SRDIV I $D(^SRO(133,SRDIV,6,DT,1,DUZ)) S SRCPT=1 Q
  1. Q:SRCPT D COPY^ICPTAPIU I $G(IOST)'["P-" W ! K DIR S DIR("A")="Press the 'Return' key to continue",DIR(0)="FOA" D ^DIR K DIR
  1. K DD,DO,DA,DIC S SRDIV=$O(^SRO(133,0))
  1. I '$D(^SRO(133,SRDIV,6,DT,0)) S X=DT,DA(1)=SRDIV,DIC="^SRO(133,SRDIV,6,",DIC("P")=$P(^DD(133,36,0),"^",2),DIC(0)="L",DINUM=X D FILE^DICN K DD,DO,DA,DIC I Y=-1 Q
  1. S X=DUZ,DA(2)=SRDIV,DA(1)=DT,DIC="^SRO(133,SRDIV,6,DT,1,",DIC("P")=$P(^DD(133.036,1,0),"^",2),DIC(0)="L",DINUM=X D FILE^DICN K DA,DD,DIC,DO
  1. Q
  1. EN2 ; set view only and titles for screens
  1. I '$D(^XUSEC("SROEDIT",DUZ)) S Q3("VIEW")=""
  1. Q:'$D(SRTN) Q:SRTN<1 S:'$D(ST) ST="SCHEDULING" S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRN=$E(VADM(1),1,20),Q3(1)="** "_ST_" ** CASE #"_SRTN_" "_SRN_" "
  1. Q
  1. DEV S SRION=$S($D(ION):ION,1:"HOME") K %ZIS S %ZIS="QN",IOP=X D ^%ZIS I POP S IOP=SRION D ^%ZIS K %ZIS,IOP,SRION,X Q
  1. W $S(X=$E(ION,1,$L(X)):$E(ION,$L(X)+1,$L(ION)),1:" "_ION) S X=ION D ^%ZISC K %ZIS,SRION,IOP Q
  1. Q
  1. TIME ; transform time to date of operation at that time
  1. I $D(SRSMED) S DA=SRTN
  1. S:$D(SRTN) SRTDA=DA,DA=SRTN S X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
  1. S %DT="EPTXR" D ^%DT S X=Y G:'$D(^SRF(DA,.2)) RESET I X>0 S SRSTART=$P(^SRF($S($D(SRTN):SRTN,1:DA),.2),"^",15) I SRSTART'="" D BEFORE
  1. S:$D(SRTDA) DA=SRTDA Q
  1. BEFORE W:X<SRSTART !!,"The time entered is before the 'TIME PAT IN HOLD AREA'. Please check the",!,"DATE/TIME entered for this field." H 2
  1. Q
  1. RESET S:$D(SRTDA) DA=SRTDA Q
  1. INPUT ; input transfor for ASA CLASS
  1. S:'$D(DA) DA=SRTN S SRFLD=1.13 I $D(^SRF(DA,"CON")),$P(^("CON"),"^") D ^SROCON Q
  1. Q
  1. PARAM ; enter/edit site parameters
  1. W @IOF K DIC,DINUM S DIC=133,DIC(0)="QEAMZL",DLAYGO=133,DIC("A")="Edit Parameters for which Surgery Site: " D ^DIC K DIC I Y<0 W @IOF Q
  1. N SRDIV,SRN,SRNAME,SRNUM S SRDIV=+Y,SRN=+Y(0),SRNAME=Y(0,0),SRNUM=$$GET1^DIQ(4,SRN,99),Q3(1)=" "_SRNAME_" ("_SRNUM_") "
  1. K DIE,DR,DA,Y S DA=SRDIV,DR="[SRPARAM]",DIE=133 D ^SRCUSS K DR,DIE,DA,ST W @IOF I $D(SRSITE) D SET
  1. Q
  1. EXIT ; exit action for all Surgery options
  1. I $D(XQY),$G(SRSITE("OPTION"))=XQY K SRSITE,SRTN,^TMP("SRCUSS",$J)
  1. D CLEAR
  1. Q
  1. SITE() ; extrinsic call to output Institution file pointer (from Default Institution field in file 4.3)^Institution name^Station number
  1. N SITE,SRI,SRX,SRY
  1. S SITE=$$KSP^XUPARAM("INST") I 'SITE Q SITE
  1. S X=SITE,DIC="^SRO(133,",DIC(0)="UBZ" D ^DIC Q:Y<0 ""
  1. S SRX=+Y I $P($G(^SRO(133,SRX,0)),U,21) S SITE="" D I 'SITE Q SITE
  1. .S SRX=0 F S SRX=$O(^SRO(133,SRX)) Q:SRX'>0 I $D(^(SRX,0)),'$P(^(0),U,21) S SITE=$P(^(0),U) Q
  1. S SRX=SITE F SRI=.01,99 S SRY=$$GET1^DIQ(4,SRX,SRI),SITE=SITE_"^"_SRY
  1. Q SITE
  1. OFF1 ; compare time off with time on
  1. S Z=$E($P(^SRF($S($D(SRTN):SRTN,1:DA(1)),0),"^",9),1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X) K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
  1. S SRSTART=$P(^SRF(DA(1),SRSUB,DA,0),"^",SRP) D COMP
  1. Q
  1. OFF2 ; compare time off with time on
  1. S Z=$E($P(^SRF($S($D(SRTN):SRTN,1:DA(2)),0),"^",9),1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X) K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
  1. S SRSTART=$P(^SRF(DA(2),SRSUB,DA(1),1,DA,0),"^",SRP)
  1. COMP I X<SRSTART W !!,"Time Off should be later than Time On.",! S X=-1
  1. OUT K %DT,SR130,SRN,SRP,SRSTART,SRSUB
  1. Q
  1. TERM ; compare stop time with start time
  1. N SRINOR,SRSTART,SRV,SRY,T,Z
  1. I $D(DA) S SRINOR=$S($P($G(^SRF(DA,"NON")),"^")="Y":$P($G(^SRF(DA,"NON")),"^",4),1:$P($G(^SRF(DA,.2)),"^",10)) I 'SRINOR D K X D OUT Q
  1. .D EN^DDIOL(">>> Please enter 'TIME "_$S($P($G(^SRF(DA,"NON")),"^")="Y":"PROCEDURE BEGAN",1:"PAT IN OR")_"' first !! <<<","","!!?5")
  1. .D EN^DDIOL("","","!")
  1. S Z=$E(SRINOR,1,7),X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
  1. K %DT,Z S %DT="PTXR" D ^%DT S X=Y I Y<1 D OUT Q
  1. I $D(DA) S Z=$P($G(^SRF(DA,SRN)),"^",SRP),SRSTART=$S(Z:Z,1:SRINOR),SRNULL=$S(Z:0,1:1) I X<SRSTART S Z=$P(SRINOR,"."),T=$P(X,".",2),X1=Z_"."_T,X2=1 D C^%DTC D PLUS24 I '$D(X) D OUT Q
  1. K %DT S %DT="EPTXR" D ^%DT S X=Y D OUT
  1. Q
  1. PLUS24 S:SRNULL SR130="TIME PAT IN OR" S (SRV,Y)=X X ^DD("DD") S SRY=Y
  1. N DIR S DIR("A",1)="",DIR("A",2)="The time you have entered is earlier than "_SR130_".",DIR("A")="Do you mean "_SRY_" (Y/N) ? ",DIR(0)="YA" D ^DIR K DIR I 'Y!$D(DTOUT)!$D(DUOUT) K X Q
  1. S X=SRV
  1. Q
  1. CLEAR ; clean-up case edit/lock flags in ^XTMP
  1. N SRC,SRJ,SRL,SRNOW,SRNOW1,SRZ S SRNOW=$$NOW^XLFDT
  1. S SRC="SRLOCK-0" F S SRC=$O(^XTMP(SRC)) Q:SRC'["SRLOCK-" D
  1. .S SRJ=0 F S SRJ=$O(^XTMP(SRC,DUZ,SRJ)) Q:'SRJ D
  1. ..I SRJ=$J L -^XTMP(SRC,DUZ,SRJ) K ^XTMP(SRC,DUZ,SRJ) I '$O(^XTMP(SRC,0)) L -^XTMP(SRC) K ^XTMP(SRC) Q
  1. ..S SRNOW1=$P($G(^XTMP(SRC,0)),"^") I SRNOW>SRNOW1 L -^XTMP(SRC) K ^XTMP(SRC)
  1. Q
  1. EN3 ; the Sterility Expiration Date should be after the Date of Operation
  1. S:$D(SRTN) SRTDA=DA,DA=SRTN S X=$S(X?1.4N.A!(X?1.2N1":"2N.A):Z_"@"_X,1:X)
  1. S %DT="E" D ^%DT S X=Y I X>0 S SRSTART=$E($P(^SRF($S($D(SRTN):SRTN,1:D0),0),U,9),1,7) I SRSTART'="" D BEF
  1. S:$D(SRTDA) DA=SRTDA Q
  1. BEF I X<SRSTART W !!,"The date entered is before the 'DATE OF OPERATION'. Please check the",!,"DATE entered for this field." K X H 2
  1. Q