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

SRTPDONR.m

Go to the documentation of this file.
  1. SRTPDONR ;BIR/SJA - DONOR INFORMATION ;03/04/08
  1. ;;3.0;Surgery;**167,175**;24 Jun 93;Build 6
  1. I '$D(SRTPP) W !!,"A Transplant Assessment must be selected prior to using this option.",!!,"Press <RET> to continue " R X:DTIME G END
  1. N SRX,SRY,SRZ
  1. START Q:SRSOUT D DISP
  1. W !!,"Select Transplant Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 G END
  1. I X="" D:$P(SR("RA"),"^",2)="K" ^SRTPKID6 G END
  1. S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
  1. I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP G:SRSOUT END G START
  1. I X="A" S X="1:"_SRX
  1. D HDR^SRTPUTL
  1. I X?1.2N1":"1.2N D RANGE G START
  1. I $D(SRAO(X)),+X=X S SREMIL=X D ONE G START
  1. END W @IOF
  1. Q
  1. HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit. Examples of proper",!,"responses are listed below."
  1. W !!,"1. Enter 'A' to update all items.",!!,"2. Enter a number (1-"_SRX_") to update the information in that field. (For example,",!," enter '1' to update Donor Race)"
  1. W !!,"3. Enter a range of numbers (1-"_SRX_") separated by a ':' to enter a range",!," of items. (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
  1. PRESS W ! K DIR S DIR("A")="Press the return key to continue or '^' to exit: ",DIR(0)="FOA" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
  1. Q
  1. RANGE ; range of numbers
  1. S SRNOMORE=0,SRSHEMP=$P(X,":"),SRCURL=$P(X,":",2) F SREMIL=SRSHEMP:1:SRCURL Q:SRNOMORE D ONE
  1. Q
  1. ONE ; edit one item
  1. I SREMIL=1 D ^SRTPRACE Q
  1. K DR,DIE S DA=SRTPP,DR=$P(SRAO(SREMIL),"^",2)_"T",DIE=139.5 D ^DIE K DR I $D(Y) S SRNOMORE=1
  1. I SREMIL=10,($P($G(^SRT(SRTPP,3)),"^")'=""&($P($G(^SRT(SRTPP,3)),"^")'="NS")) S $P(^SRT(SRTPP,3),"^",2)="NS" Q
  1. I SREMIL=11,($P($G(^SRT(SRTPP,3)),"^",2)'=""&($P($G(^SRT(SRTPP,3)),"^",2)'="NS")) S $P(^SRT(SRTPP,3),"^")="NS" Q
  1. Q
  1. DISP ; display fields
  1. S SRHPG="DONOR INFORMATION",SRPAGE="PAGE: "_$S(SRNOVA:5,1:4)_" OF "_$S(SRNOVA:6,1:5)
  1. I $P(SR("RA"),"^",2)="H" S SRPAGE="PAGE: "_$S(SRNOVA:6,1:4)_" OF "_$S(SRNOVA:6,1:4)
  1. D HDR^SRTPUTL
  1. K DR,SRAO S (DR,SRDR)="45;31;36;70;46;48;49;77;69;103;104;64;65;66;73;67;72" S SRAO(1)=""
  1. K DA,DIC,DIQ,SRX,SRY,SRZ S DIC="^SRT(",DA=SRTPP,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
  1. S (SRX,SRZ)=0 F I=1:1 S SRZ=$P(SRDR,";",I) Q:'SRZ S SRX=I,SRAO(I+1)=SRY(139.5,SRTPP,SRZ,"E")_"^"_SRZ
  1. S SRX=SRX+1
  1. ; race information
  1. K SRY,SRZ S DIC="^SRT(",DR=44,DA=SRTPP,DR(139.544)=".01"
  1. S (II,JJ)=0 F S II=$O(^SRT(SRTPP,44,II)) Q:'II S SRACE=$G(^SRT(SRTPP,44,II,0)) D K SRY
  1. .S DA(139.544)=II,DIQ="SRY",DIQ(0)="E" D EN^DIQ1
  1. .S JJ=JJ+1,SRZ(139.544,JJ)=SRACE_"^"_$G(SRY(139.544,II,.01,"E")),SRZ(139.544)=JJ
  1. D RACE
  1. W !,"1. Donor Race:" S SRAO(1)="" I $G(SRZ(139.544)) F D=1:1:SRNUM1-1 W:D=1 ?18,SROL(D) W:D'=1 !,?18,SROL(D)
  1. W !,"2. Donor Gender:",?27,$P(SRAO(2),"^")
  1. W !,"3. Donor Height:",?27,$P(SRAO(3),"^"),?43,"HLA Typing (#,#,#,#)"
  1. W !,"4. Donor Weight:",?27,$P(SRAO(4),"^"),?43,"===================="
  1. W !,"5. Donor DOB:",?27,$P(SRAO(5),"^"),?43,"13. Donor HLA-A: ",$P(SRAO(13),"^")
  1. W !,"6. Donor Age:",?27,$P(SRAO(6),"^"),?43,"14. Donor HLA-B: ",$P(SRAO(14),"^")
  1. W !,"7. Donor ABO Blood Type:",?27,$P(SRAO(7),"^"),?43,"15. Donor HLA-C: ",$P(SRAO(15),"^")
  1. W !,"8. Donor CMV:",?27,$P(SRAO(8),"^"),?43,"16. Donor HLA-DR: ",$P(SRAO(16),"^")
  1. W !,"9. Donor Substance Abuse:",?27,$P(SRAO(9),"^"),?43,"17. Donor HLA-BW: ",$P(SRAO(17),"^")
  1. W !,"10. Deceased Donor:",?27,$P($P(SRAO(10),"^"),"("),?43,"18. Donor HLA-DQ: ",$P(SRAO(18),"^")
  1. W !,"11. Living Donor:",?27,$P(SRAO(11),"^")
  1. W !,"12. Donor with Malignancy:",?27,$P(SRAO(12),"^")
  1. W !!,SRLINE
  1. Q
  1. RACE ;Find all race entries and place into a string with commas inbetween
  1. K SROL S SRORC=0,C=1,SRORACE="",SROLINE="",N=1,SROL=""
  1. F S SRORC=$O(SRZ(139.544,SRORC)) Q:SRORC="" Q:C=11 D
  1. .I $D(SRZ(139.544,SRORC)) S SRORACE(C)=$P(SRZ(139.544,SRORC),"^",2)
  1. .I SROLINE'="" S SROLINE=SROLINE_", "_SRORACE(C)
  1. .I SROLINE="" S SROLINE=SRORACE(C)
  1. .S C=C+1
  1. ;Find total length of 'race' string and wrap the text if necessary
  1. I $L(SROLINE)=45!$L(SROLINE)<45 S SROL(N)=SROLINE,SRNUM1=2
  1. I $L(SROLINE)>45 D WRAP
  1. K SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP
  1. Q
  1. WRAP ;Wrap multiple race entries so that wrapped line
  1. ;does not break in the middle of a word
  1. ;
  1. S SROLNGTH=$L(SROLINE),E=45,SROWRAP="",SROLN="",SROLN1="",SROL=""
  1. F I=1:45:SROLNGTH S SROLN(I)=SROWRAP_$E(SROLINE,I,E) D
  1. .F K=45:-1:1 I $E(SROLN(I),K)[" " D Q ;Break lines at space
  1. ..S SROLN1(I)=$E(SROLN(I),1,K-1)
  1. ..S SROWRAP=$E(SROLN(I),K+1,E)
  1. .S E=E+45
  1. ;
  1. S:'$D(SROLN1(I)) SROLN1(I)=SROLN(I),SROWRAP=""
  1. I $L(SROLN1(I))+$L(SROWRAP)>44 S SROLN1(I+1)=SROWRAP ;Last line
  1. I $L(SROLN1(I))+$L(SROWRAP)'>44 S SROLN1(I)=SROLN1(I)_" "_SROWRAP
  1. ;
  1. ;Renumber the SROLN1 array to be in numeric order
  1. S SRNUM=0,SRNUM1=1
  1. F S SRNUM=$O(SROLN1(SRNUM)) Q:SRNUM="" D
  1. .S SROL(SRNUM1)=SROLN1(SRNUM)
  1. .S SRNUM1=SRNUM1+1
  1. Q