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

LRAPED.m

Go to the documentation of this file. 
  1. LRAPED ;DALOI/STAFF,PMK - ANATOMIC PATH EDIT LOG-IN ;17 Sep 2013 7:31 AM
  1.  ;;5.2;LAB SERVICE;**1,31,72,115,259,350,427,433,428**;Sep 27, 1994;Build 16
  1.  ;
  1.  ;RB LR*5.2*428 Added code to insure a defined site hospital location
  1.  ;              can be entered when editing the patient location field.
  1.  ;              This insures the correct location and patient type will
  1.  ;              be propagated to corresponding fields in file #68 and
  1.  ;              #69. This insures the log book reflects the correct
  1.  ;              patient location and CPT data transfer to PCE will be
  1.  ;              based on an accurate patient type.
  1.  ;
  1.  N LRTMP,LRREL,LRCOMP,LRMSG
  1.  D ^LRAP Q:'$D(Y)
  1.  D XR^LRU
  1.  I LRCAPA D @(LRSS_"^LRAPSWK") G:'$D(X) END
  1.  W !!,"EDIT ",LRO(68)," (",LRABV,") Log-In/Clinical Hx for ",LRH(0)," "
  1.  S %=1 D YN^LRU G:%<1 END
  1.  I %=2 D  G:Y<1 END
  1.  . S %DT="AE",%DT(0)="-N",%DT("A")="Enter YEAR: "
  1.  . D ^%DT K %DT
  1.  . Q:Y<1
  1.  . S LRAD=$E(Y,1,3)_"0000",Y=LRAD D D^LRU S LRH(0)=Y
  1.  S LRC=$E(LRAD,1,3)
  1. G ;
  1.  W !!,"Enter ",LRO(68)," Accession #: " R LRAN:DTIME
  1.  G:LRAN=""!(LRAN[U) END
  1.  I LRAN'?1N.N!($E(LRAN)=0) D  G G
  1.  .W $C(7),!," ENTER NUMBERS ONLY, No leading zero's"
  1.  D EDIT I $G(END)=1 K END    ;LR*5.2*428 quit if not valid location
  1.  ;
  1.  I $T(EDIT^MAGT7MA)'="" D EDIT^MAGT7MA ; invoke Imaging HL7 routine - P433
  1.  ;
  1.  G G
  1.  ;
  1.  ;
  1. EDIT ;
  1.  N LRDIWESUB,LRFILE,LRACC
  1.  S LRDFN=$O(^LR(LRXREF,LRC,LRABV,LRAN,0))
  1.  I 'LRDFN W $C(7),"  Not in file" Q
  1.  I '$D(^LR(LRDFN,0)) K ^LR(LRXREF,LRC,LRABV,LRAN,LRDFN) Q
  1.  S X=^LR(LRDFN,0) D ^LRUP W !,LRP," ID: ",SSN," OK "
  1.  S %=1 D YN^LRU Q:%'=1
  1.  D @($S("CYEMSP"[LRSS:"I",1:"A"))
  1.  Q
  1.  ;
  1.  ;
  1. I ;Non-autopsy sections (SP,CY,EM)
  1.  D GETDEF^LRAP
  1.  S LRI=+$O(^LR(LRXREF,LRC,LRABV,LRAN,LRDFN,0))
  1.  I '$D(^LR(LRDFN,LRSS,LRI,0)) D  Q
  1.  . W $C(7),!,"Entry in x-ref but not in file ! X-ref deleted."
  1.  . K ^LR(LRXREF,LRC,LRABV,LRAN,LRDFN,LRI)
  1.  S X=^LR(LRDFN,LRSS,LRI,0),LRRC=$P(X,"^",10)
  1.  S DA=LRI,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""",",(LRB,Y)=+X
  1.  D D^LRU W !,"Specimen date: ",Y
  1.  I $P(^LR(LRDFN,LRSS,LRI,0),"^",11)!($P(^(0),"^",3)) D  Q
  1.  . W $C(7),!!,"Report released or completed.  Cannot edit Log-in data."
  1.  D:LRCAPA C^LRAPSWK
  1.  ;
  1. DIE ;
  1.  ;
  1.  W ! D CK^LRU
  1.  I $D(LR("CK")) K LR("CK") Q
  1.  S LRACC=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",6)
  1.  ;
  1.  S LRDIWESUB="["_LRACC_"]"
  1.  ;
  1.  ;LR*5.2*428 START: ASK LOCATION PER FILE 44 DEFINED
  1.  S LRLLOC=$P($G(^LR(LRDFN,LRSS,LRI,0)),"^",8)
  1.  D ASK I $G(END)=1 Q
  1.  ;
  1.  S DA=LRI,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","
  1.  S DR=".08///^S X=LRLLOC" D ^DIE K DR
  1.  ;SET Associated files 68 & 69 LOCATION & TYPE fields
  1.  D UIDEX      ;propagate LOCATION/TYPE info to files 68 & 69 fields
  1.  ;LR*5.2*428 END: ASK LOCATION PER FILE 44 DEFINED
  1.  ;
  1.  S DA=LRI,DA(1)=LRDFN,DIE="^LR("_LRDFN_","""_LRSS_""","  ;LR*5.1*428 restore previous DIE setup
  1.  D SET,^DIE
  1.  I $D(Y) D HELP G DIE
  1.  D CK
  1.  D:$O(^LR(LRDFN,LRSS,LRI,.1,0))&("SPCYEM"[LRSS)&(LRCAPA) C1^LRAPSWK
  1.  D FRE^LRU
  1.  Q
  1.  ;
  1.  ;
  1. SET ; Setup fields for SP, CY and EM subscripts to edit.
  1.  ;
  1.  ;N LRFIELD,LRFILE
  1.  ;S LRFILE=$S(LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,1:"")
  1.  ;F LRFIELD=.013,.014,.015,.016 S LRDIWESUB(LRFILE,LRFIELD)=$$SET2(LRFILE,LRFIELD,LRACC)
  1.  ;
  1.  S (LRJ,LRE,LRF)=""
  1.  S DR=".07;S LRJ=X;S:LRJ LRJ=$P(^VA(200,LRJ,0),U);"     ;LR*5.2*428 Remove .08 field edit
  1.  S DR=DR_".011//^S X=LRJ;.012;.013;.014;.015;.016;.1;S LRG=X;.02;.021;"
  1.  S DR=DR_".99;S LRF=X"
  1.  ;
  1.  I LRSS="SP" D
  1.  . S DR(2,63.812)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
  1.  . S DR(2,63.812)=DR(2,63.812)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
  1.  ;
  1.  I LRSS="CY" D
  1.  . S DR(2,63.902)=".01;S LR(63.902)=X;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
  1.  . S DR(2,63.902)=DR(2,63.902)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U);S:'LRCAPA Y=""@2"";.02;@2"
  1.  ;
  1.  I LRSS="EM" D
  1.  . S DR(2,63.202)=".01;.06R//^S X=LRSPTOP(0);S:X LRSPTOP=X,LRSPTOP(0)=$P(^LAB(61,LRSPTOP,0),U)"
  1.  . S DR(2,63.202)=DR(2,63.202)_";.07R//^S X=LRSAMP(0);S:X LRSAMP=X,LRSAMP(0)=$P(^LAB(62,LRSAMP,0),U)"
  1.  Q
  1.  ;
  1.  ;
  1. SET1 ; Setup autopsy fields to edit.
  1.  ;
  1.  S LRJ="",DA=LRDFN,DIE="^LR(",DR="11;S LRRC=X;14.1;S LRLLOC=X;14.5;"
  1.  S DR=DR_"14.6;S LRSVC=X;12.1;S LRMD=X;13.5:13.8"
  1.  S:%=1 DR=DR_";16:24;26:31;25;31.1:31.4;25.1:25.9"
  1.  D D^LRAUAW
  1.  S (Y,LRB)=LR(63,12),LRI=9999999-$P(LRB,".")
  1.  Q
  1.  ;
  1.  ;
  1. SET2(FILE,FIELD,PREFIX) ; Build field name with specified prefix.
  1.  ; Call with  FILE = file or subfile number
  1.  ;           FIELD = field number of WP field
  1.  ;          PREFIX = prefix for subject header
  1.  ;
  1.  N LABEL
  1.  S LABEL=$$GET1^DID(FILE,FIELD,"","LABEL")
  1.  I LABEL'="" S LABEL=PREFIX_" "_LABEL
  1.  ;
  1.  Q LABEL
  1.  ;
  1.  ;
  1. A ;Autopsy
  1.  S LRREL=+$$GET1^DIQ(63,LRDFN_",",14.7,"I")
  1.  S LRCOMP=+$$GET1^DIQ(63,LRDFN_",",13,"I")
  1.  I LRREL!LRCOMP D  Q
  1.  . D EN^DDIOL($C(7)_"Report released or completed.  Cannot edit Log-in data.","","!!")
  1.  W !!,"Edit Weights & Measurements " S %=2 D YN^LRU Q:%<1
  1.  S LRRC=$P(^LR(LRDFN,"AU"),U),DA=LRDFN,DIE="^LR("
  1.  D SET1,D^LRU
  1.  W !!,"Date Died: ",Y
  1.  I 'LRB D  Q
  1.  . W $C(7),"?  Must have date died entered in ",LR(63,.02)," File."
  1.  ;
  1.  S LRACC=$P($G(^LR(LRDFN,"AU")),"^",6)
  1.  ;
  1. AU ;
  1.  ;
  1.  S LRDIWESUB="["_LRACC_"]"
  1.  W ! D ^DIE
  1.  I $D(Y) D HELP G AU
  1.  D CK1
  1.  Q
  1.  ;
  1.  ;
  1. CK ;
  1.  I '$D(^LR(LRDFN,LRSS,LRI)) D K
  1.  Q
  1.  ;
  1.  ;
  1. CK1 ;
  1.  Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))  S X=^(0)
  1.  S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) ^(3)=LRB_"^^^^"_LRI
  1.  S LRTMP=$P(X,U,1,2)_U_LRRC_U_$P(X,U,4,6)_U_LRLLOC_U_LRMD_U_LRSVC
  1.  S LRTMP=LRTMP_U_$P(X,U,10)
  1.  S ^LRO(68,LRAA,1,LRAD,1,LRAN,0)=LRTMP
  1.  S LRD=+$P(X,U,3)
  1.  K ^LRO(68,LRAA,1,LRAD,1,"E",LRD,LRAN)
  1.  S ^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)=""
  1.  S X=^LRO(68,LRAA,1,LRAD,1,LRAN,3),^(3)=LRB_U_$P(X,U,2,99)
  1.  Q
  1.  ;
  1.  ;
  1. K ;
  1.  Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN))  D K^LRUDEL
  1.  L +^LRO(68,LRAA):999
  1.  K ^LRO(68,LRAA,1,LRAD,1,LRAN),^LRO(68,LRAA,1,LRAD,1,"E",LRRC,LRAN)
  1.  K ^LRO(68,LRAA,1,"AC",DUZ(2),LRAD,LRAN)
  1.  S X=^LRO(68,LRAA,1,LRAD,1,0)
  1.  S LRTMP=$P(X,"^",1,2)_"^"_(LRAN-1)_"^"_($P(X,"^",4)-1)
  1.  S ^LRO(68,LRAA,1,LRAD,1,0)=LRTMP
  1.  L -^LRO(68,LRAA)
  1.  F A=1,2,3,4 D
  1.  . I $D(^LRO(69.2,LRAA,A,LRAN)) K ^(LRAN) D
  1.  . . S X(1)=$O(^LRO(69.2,LRAA,A,0)) S:'X(1) X(1)=0
  1.  . . I $D(^LRO(69.2,LRAA,A,0)) D
  1.  . . . L +^LRO(69.2,LRAA,A):999
  1.  . . . S X=^LRO(69.2,LRAA,A,0)
  1.  . . . S LRTMP=$P(X,"^",1,2)_"^"_X(1)_"^"_$S(X(1)=0:X(1),1:($P(X,"^",4)-1))
  1.  . . . S ^LRO(69.2,LRAA,A,0)=LRTMP
  1.  . . . L -^LRO(69.2,LRAA,A)
  1.  Q
  1.  ;
  1.  ;
  1. HELP ;
  1.  W $C(7),!!,"Please do not exit EDIT with an ""^""."
  1.  W !,"Press RETURN key repeatedly to complete the edit.",!!
  1.  Q
  1.  ;
  1.  ;LR*5.2*428 Added location query to insure location defined in file 44
  1. ASK W !,"PATIENT LOCATION: ",LRLLOC,$S(LRLLOC]"":"// ",1:"") R X:DTIME G:X[U ASKOUT I '$T&(LRLLOC="") W "   Must enter defined location" G ASK
  1.  I $L(X)>30!(X'?.ANP) W "  Enter 2 - 30 alpha-numeric name" G ASK
  1.  K DIC S DIC("S")="I '$G(^(""OOS""))"
  1.  S LROLLOC="",DIC=44,DIC(0)="EMOQZ" S:X="" X=LRLLOC D ^DIC K DIC G ASK:X["?"
  1.  I $D(DIROUT)!$D(DTOUT)!$D(DUOUT) G ASKOUT
  1.  I Y<0 W "  You must select a standard location." G ASK
  1.  S (LRE,LROLLOC)=+Y,LRLLOC=$P(Y(0),U),LRLOCTYP=$P(Y(0),U,3)
  1.  S:'$L(LRLLOC) LRLLOC="NO ABRV"
  1. INACT K LRIA,LRRA I $D(^SC(+Y,"I")) S LRIA=+^("I"),LRRA=$P(^("I"),U,2)
  1.  I $S('$D(LRIA):0,'LRIA:0,LRIA>DT:0,LRRA'>DT&(LRRA):0,1:1) W $C(7),"  Location is inactive, Not allowed." G ASK
  1. ASKQ K DIC,LRIA,LRRA,% Q
  1. ASKOUT W !,"  VALID LOCATION REQUIRED TO CONTINUE, EXITING SELECTED ACCESSION" S END=1 G ASKQ
  1.  ;
  1. END ;
  1.  D V^LRU K DUOUT,DIRUT,DTOUT
  1.  Q
  1.  ;
  1. UIDEX ;LR*5.2*428 Propagate location/type to file 68 & 69 associated fields
  1.  ;Find 68 link using UID from file 63 accession
  1.  N X1,X2,X3,X4,X5 S (X1,X2,X3)=0
  1.  S LRUID=$P($G(^LR(LRDFN,LRSS,LRI,"ORU")),U) G:LRUID="" UIDEXQ
  1.  S X1=$O(^LRO(68,"C",LRUID,X1)) G:'X1 UIDEXQ
  1.  S X2=$O(^LRO(68,"C",LRUID,X1,X2)) G:'X2 UIDEXQ
  1.  S X3=$O(^LRO(68,"C",LRUID,X1,X2,X3)) G:'X3 UIDEXQ
  1.  S DIE="^LRO(68,X1,1,X2,1,",DA=X3,DR="6////^S X=LRLLOC;92///^S X=LRLOCTYP"
  1.  D ^DIE K DR,DIE,DA,LRUID
  1.  ;Find 69 link using date/accession number in file 68
  1.  S X4=$P(^LRO(68,X1,1,X2,1,X3,0),U,4),X5=$P(^LRO(68,X1,1,X2,1,X3,0),U,5)
  1.  I X4&X5&$D(^LRO(69,X4,1,X5,0)) D
  1.  . S DIE="^LRO(69,X4,1,",DA=X5,DA(1)=X4,DR="8////^S X=LROLLOC"
  1.  D ^DIE
  1. UIDEXQ K DR,DIE,DA,LRLLOC,LRLOCTYP,LROLLOC
  1.  Q