| 1 | SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ;13 Feb 1989 11:32 AM
|
|---|
| 2 | ;;3.0;Surgery;**58,119**;24 Jun 93
|
|---|
| 3 | ENTER ; enter a patient on the waiting list
|
|---|
| 4 | S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")=" Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0)
|
|---|
| 5 | S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
|
|---|
| 6 | PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")=" Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END
|
|---|
| 7 | S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT
|
|---|
| 8 | I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
|
|---|
| 9 | OP W ! K DIR S DIR("A")=" Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END
|
|---|
| 10 | S SROPER=Y
|
|---|
| 11 | W ! D NOW^%DTC S SRSDT=%
|
|---|
| 12 | K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y
|
|---|
| 13 | K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR
|
|---|
| 14 | D WL^SROPCE1 I SRSOUT G DEL
|
|---|
| 15 | W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
|
|---|
| 16 | END D PRESS,^SRSKILL W @IOF
|
|---|
| 17 | Q
|
|---|
| 18 | PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR
|
|---|
| 19 | Q
|
|---|
| 20 | DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
|
|---|
| 21 | W @IOF,!,"Classification information is incomplete. No action taken." G END
|
|---|
| 22 | Q
|
|---|
| 23 | HELP W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_". If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option."
|
|---|
| 24 | W !!,"Press RETURN to continue " R X:DTIME
|
|---|
| 25 | Q
|
|---|
| 26 | CHK ; check for existing entries for a patient
|
|---|
| 27 | W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
|
|---|
| 28 | S SROFN=0 F S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN D LIST
|
|---|
| 29 | W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ? YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q
|
|---|
| 30 | S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
|
|---|
| 31 | I "YNn"'[ECYN D HELP G CHK
|
|---|
| 32 | Q
|
|---|
| 33 | LIST ; list existing procedures for specialty selected
|
|---|
| 34 | S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12)
|
|---|
| 35 | K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_" " S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
|
|---|
| 36 | W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
|
|---|
| 37 | I $D(SROP(2)) W !,?3,SROP(2)
|
|---|
| 38 | W !
|
|---|
| 39 | Q
|
|---|
| 40 | LOOP ; break procedure if greater than 36 characters
|
|---|
| 41 | S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<36 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
|
|---|
| 42 | Q
|
|---|
| 43 | REFPHY ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
|
|---|
| 44 | N SRCONT,Y,SRDEMO
|
|---|
| 45 | S SRCONT=""
|
|---|
| 46 | PRMPT R !,"Is this a VA Physician from this facility? (Y/N): <Y> ",SRCONT:DTIME I '$T Q
|
|---|
| 47 | I SRCONT["?" D G PRMPT
|
|---|
| 48 | .W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
|
|---|
| 49 | S:SRCONT="" SRCONT="Y"
|
|---|
| 50 | I SRCONT="^" S X="" Q
|
|---|
| 51 | Q:(SRCONT'["Y")&(SRCONT'["y")
|
|---|
| 52 | ; Store FileMan variables and arrays
|
|---|
| 53 | M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
|
|---|
| 54 | ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
|
|---|
| 55 | S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
|
|---|
| 56 | D ^DIC
|
|---|
| 57 | ; Restore FileMan's variables and arrays
|
|---|
| 58 | M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
|
|---|
| 59 | K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
|
|---|
| 60 | Q:Y="-1" ; Quit if no record was selected from the NEW PERSON file
|
|---|
| 61 | S SRNPREC=$P(Y,U,1)_"," ;The record number of the NEW PERSON file
|
|---|
| 62 | ; Retrieve demographic data from the NEW PERSON file.
|
|---|
| 63 | D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
|
|---|
| 64 | ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
|
|---|
| 65 | S X=SRDEMO(200,SRNPREC,".01") ;Name
|
|---|
| 66 | S SRDEMO(1)=SRDEMO(200,SRNPREC,".111") ;Address
|
|---|
| 67 | S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112") ;Concatenate Address 2 to single address
|
|---|
| 68 | S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113") ;Concatenate Address 3 to single address
|
|---|
| 69 | S SRDEMO(1)=$E(SRDEMO(1),1,75)
|
|---|
| 70 | S SRDEMO(2)=SRDEMO(200,SRNPREC,".114") ;City
|
|---|
| 71 | S SRDEMO(3)=SRDEMO(200,SRNPREC,".115") ;State
|
|---|
| 72 | S SRDEMO(4)=SRDEMO(200,SRNPREC,".116") ;Zip
|
|---|
| 73 | S SRDEMO(5)=SRDEMO(200,SRNPREC,".132") ;Office Phone
|
|---|
| 74 | ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
|
|---|
| 75 | S DIC("DR")="1///"_SRDEMO(1)_";2///"_SRDEMO(2)_";3///"_SRDEMO(3)_";4///"_SRDEMO(4)_";5///"_SRDEMO(5)_";6///"_$P(Y,U,1)
|
|---|
| 76 | S DIC(0)="Z" ;Tells FileMan to file the data without any more user input
|
|---|
| 77 | Q
|
|---|
